From: Arnaud Charlet Date: Thu, 27 May 2004 13:09:26 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=8a36a0ccd84d73e8bfb5989be1510536b73b9df9;p=gcc.git [multiple changes] 2004-05-27 Vincent Celier * vms_data.ads: Add new GNAT PRETTY qualifiers /NO_BACKUP and COMMENTS_LAYOUT=UNTOUCHED * symbols-vms.adb, symbols-vms-alpha.adb: Renamed symbols-vms.adb to symbols-vms-alpha.adb 2004-05-27 Thomas Quinot * sem.ads: Clarify documentation on checks suppression. * einfo.ads (Is_Known_Non_Null): Minor comment typo fix and rephrasing. 2004-05-27 Ed Schonberg * sem_util.adb (Is_Descendent_Of): Examine properly all ancestors in the case of multiple derivations. (Is_Object_Reference): For a selected component, verify that the prefix is itself an object and not a value. * sem_ch12.adb (Same_Instantiated_Constant): New name for Same_Instantiated_Entity. (Same_Instantiated_Variable): Subsidiary to Check_Formal_Package_Instance, to recognize actuals for in-out generic formals that are obtained from a previous formal package. (Instantiate_Subprogram_Body): Emit proper error when generating code and the proper body of a stub is missing. * sem_ch4.adb (Remove_Address_Interpretations): If the operation still has a universal interpretation, do the disambiguation here. * exp_ch4.adb (Expand_N_Type_Conversion, Expand_N_Unchecked_Type_Conversion): Special handling when target type is Address, to avoid typing anomalies when Address is a visible integer type. * exp_ch6.adb (Expand_N_Subprogram_Body): Use Is_Descendent_Of_Address to determine whether a subprogram should not be marked Pure, even when declared in a pure package. 2004-05-27 Jose Ruiz * gnat_ugn.texi: Replace pragma Ravenscar by pragma Profile. * gnat_rm.texi: Replace Max_Entry_Queue_Depth by Max_Entry_Queue_Length Document No_Dynamic_Attachment, that supersedes No_Dynamic_Interrupts. Update the documentation about the Ravenscar profile, following the definition found in AI-249. * sem_prag.adb: Use FIFO_Within_Priorities and Ceiling_Locking when setting the Profile (Ravenscar). This must be done in addition to setting the required restrictions. * rtsfind.ads: Add the set of operations defined in package Ada.Interrupts. * exp_ch6.adb: Check whether we are violating the No_Dynamic_Attachment restriction. 2004-05-27 Eric Botcazou lang-specs.h: Always require -c or -S and always redirect to /dev/null if -gnatc or -gnats is passed. 2004-05-27 Hristian Kirtchev * sem_prag.adb (Sig_Flags): A Pragma_Unchecked_Union does not count as a significant reference. Warnings are now properly emitted when a discriminated type is not referenced. * lib-xref.adb (Generate_Reference): A deferred constant completion, record representation clause or record type discriminant does not produce a reference to its corresponding entity. Warnings are now properly emitted when deferred constants and record types are not referenced. 2004-05-27 Geert Bosch * Makefile.in: Use long version of libm routines on ia64 gnu/linux. Fixes ACATS Annex G tests. 2004-05-27 Robert Dewar * rtsfind.adb (RTU_Loaded): Temporary kludge to get past bug of not handling WITH 2004-05-27 Arnaud Charlet * s-interr.adb (Server_Task): Take into account case of early return from sigwait under e.g. linux. 2004-05-27 Sergey Rybin * gnat_ugn.texi: Add description for the new gnatpp options: -rnb - replace the original source without creating its backup copy -c0 - do not format comments From-SVN: r82324 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a3d34f66dc4..f829316f405 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,101 @@ +2004-05-27 Vincent Celier + + * vms_data.ads: Add new GNAT PRETTY qualifiers /NO_BACKUP and + COMMENTS_LAYOUT=UNTOUCHED + + * symbols-vms.adb, symbols-vms-alpha.adb: Renamed symbols-vms.adb to + symbols-vms-alpha.adb + +2004-05-27 Thomas Quinot + + * sem.ads: Clarify documentation on checks suppression. + + * einfo.ads (Is_Known_Non_Null): Minor comment typo fix and rephrasing. + +2004-05-27 Ed Schonberg + + * sem_util.adb (Is_Descendent_Of): Examine properly all ancestors in + the case of multiple derivations. + (Is_Object_Reference): For a selected component, verify that the prefix + is itself an object and not a value. + + * sem_ch12.adb (Same_Instantiated_Constant): New name for + Same_Instantiated_Entity. + (Same_Instantiated_Variable): Subsidiary to + Check_Formal_Package_Instance, to recognize actuals for in-out generic + formals that are obtained from a previous formal package. + (Instantiate_Subprogram_Body): Emit proper error when + generating code and the proper body of a stub is missing. + + * sem_ch4.adb (Remove_Address_Interpretations): If the operation still + has a universal interpretation, do the disambiguation here. + + * exp_ch4.adb (Expand_N_Type_Conversion, + Expand_N_Unchecked_Type_Conversion): Special handling when target type + is Address, to avoid typing anomalies when Address is a visible integer + type. + + * exp_ch6.adb (Expand_N_Subprogram_Body): Use Is_Descendent_Of_Address + to determine whether a subprogram should not be marked Pure, even when + declared in a pure package. + +2004-05-27 Jose Ruiz + + * gnat_ugn.texi: Replace pragma Ravenscar by pragma Profile. + + * gnat_rm.texi: Replace Max_Entry_Queue_Depth by Max_Entry_Queue_Length + Document No_Dynamic_Attachment, that supersedes No_Dynamic_Interrupts. + Update the documentation about the Ravenscar profile, following the + definition found in AI-249. + + * sem_prag.adb: Use FIFO_Within_Priorities and Ceiling_Locking when + setting the Profile (Ravenscar). This must be done in addition to + setting the required restrictions. + + * rtsfind.ads: Add the set of operations defined in package + Ada.Interrupts. + + * exp_ch6.adb: Check whether we are violating the No_Dynamic_Attachment + restriction. + +2004-05-27 Eric Botcazou + + lang-specs.h: Always require -c or -S and always redirect to /dev/null + if -gnatc or -gnats is passed. + +2004-05-27 Hristian Kirtchev + + * sem_prag.adb (Sig_Flags): A Pragma_Unchecked_Union does not count as + a significant reference. Warnings are now properly emitted when a + discriminated type is not referenced. + + * lib-xref.adb (Generate_Reference): A deferred constant completion, + record representation clause or record type discriminant does not + produce a reference to its corresponding entity. Warnings are now + properly emitted when deferred constants and record types are not + referenced. + +2004-05-27 Geert Bosch + + * Makefile.in: Use long version of libm routines on ia64 gnu/linux. + Fixes ACATS Annex G tests. + +2004-05-27 Robert Dewar + + * rtsfind.adb (RTU_Loaded): Temporary kludge to get past bug of not + handling WITH + +2004-05-27 Arnaud Charlet + + * s-interr.adb (Server_Task): Take into account case of early return + from sigwait under e.g. linux. + +2004-05-27 Sergey Rybin + + * gnat_ugn.texi: Add description for the new gnatpp options: + -rnb - replace the original source without creating its backup copy + -c0 - do not format comments + 2004-05-24 Geert Bosch * a-numaux-x86.adb (Reduce): Reimplement using an approximation of Pi diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 79d404516e7..bf691bb3aa2 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -1260,6 +1260,7 @@ endif ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads Expr -@findex Max_Entry_Queue_Depth +@item Max_Entry_Queue_Length => Expr +@findex Max_Entry_Queue_Length This restriction is a declaration that any protected entry compiled in the scope of the restriction has at most the specified number of tasks waiting on the entry @@ -6879,10 +6903,10 @@ from Boolean). This is intended for use in safety critical programs where the certification protocol requires the use of short-circuit (and then, or else) forms for all composite boolean operations. -@item No_Dynamic_Interrupts -@findex No_Dynamic_Interrupts -This restriction ensures at compile time that there is no attempt to -dynamically associate interrupts. Only static association is allowed. +@item No_Dynamic_Attachment +@findex No_Dynamic_Attachment +This restriction ensures that there is no call to any of the operations +defined in package Ada.Interrupts. @item No_Enumeration_Maps @findex No_Enumeration_Maps @@ -6978,7 +7002,7 @@ on some targets. This restriction ensures at compile time no select statements of any kind are permitted, that is the keyword @code{select} may not appear. This is one of the restrictions of the Ravenscar -profile for limited tasking (see also pragma @code{Ravenscar}). +profile for limited tasking (see also pragma @code{Profile (Ravenscar)}). @item No_Standard_Storage_Pools @findex No_Standard_Storage_Pools diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index c75882bc78c..300e9602128 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -9995,9 +9995,9 @@ recognized by @code{GNAT}: Long_Float Normalize_Scalars Polling + Profile Propagate_Exceptions Queuing_Policy - Ravenscar Restricted_Run_Time Restrictions Reviewable @@ -14647,6 +14647,9 @@ on their effect. @table @option @cindex @option{^-c@var{n}^/COMMENTS_LAYOUT^} (@command{gnatpp}) +@item ^-c0^/COMMENTS_LAYOUT=UNTOUCHED^ +All the comments remain unchanged + @item ^-c1^/COMMENTS_LAYOUT=DEFAULT^ GNAT-style comment line indentation (this is the default). @@ -14680,7 +14683,8 @@ stops. @noindent The @option{-c1} and @option{-c2} switches are incompatible. The @option{-c3} and @option{-c4} switches are compatible with each other and -also with @option{-c1} and @option{-c2}. +also with @option{-c1} and @option{-c2}. The @option{-c0} switch disables all +the other comment formatting switches. The @option{-l1}, @option{-l2}, and @option{-l3} switches are incompatible. @end ifclear @@ -14827,6 +14831,11 @@ reading or processing the input file. @cindex @option{^-rf^/OVERRIDING_REPLACE^} (@code{gnatpp}) Like @option{^-r^/REPLACE^} except that if the file with the specified name already exists, it is overwritten. + +@item ^-rnb^/NO_BACKUP^ +@cindex @option{^-rnb^/NO_BACKUP^} (@code{gnatpp}) +Replace the input source file with the reformatted output without +creating any backup copy of the input source. @end table @noindent diff --git a/gcc/ada/lang-specs.h b/gcc/ada/lang-specs.h index 8cd85a81c60..1de5f4e134e 100644 --- a/gcc/ada/lang-specs.h +++ b/gcc/ada/lang-specs.h @@ -32,13 +32,12 @@ {"@ada", "\ %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ - %{!gnatc*:%{!gnats*:%{!S:%{!c:\ - %eone of -c, -S, -gnatc or -gnats is required for Ada}}}}\ + %{!S:%{!c:%e-c or -S required for Ada}}\ gnat1 %{I*} %{k8:-gnatk8} %{w:-gnatws} %1 %{!Q:-quiet} %{nostdinc*}\ %{nostdlib*}\ -dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\ %{g*} %{O*} %{W*} %{w} %{p} %{pg:-p} %{m*} %{a} %{f*} %{d*}\ %{!S:%{o*:%w%*-gnatO}} \ %i %{S:%W{o*}%{!o*:-o %b.s}} \ - %{!S:%{gnatc*|gnats*: -o %j}} \ + %{gnatc*|gnats*: -o %j} \ %{!gnatc*:%{!gnats*:%(invoke_as)}}", 0, 0, 0}, diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 107c84951c2..1f271e89c21 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -269,6 +269,27 @@ package body Lib.Xref is then null; + -- Constant completion does not count as a reference + + elsif Typ = 'c' + and then Ekind (E) = E_Constant + then + null; + + -- Record representation clause does not count as a reference + + elsif Nkind (N) = N_Identifier + and then Nkind (Parent (N)) = N_Record_Representation_Clause + then + null; + + -- Discriminants do not need to produce a reference to record type + + elsif Typ = 'd' + and then Nkind (Parent (N)) = N_Discriminant_Specification + then + null; + -- Any other occurrence counts as referencing the entity else diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index b43da3db603..720ad257a83 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -147,8 +147,8 @@ package body Rtsfind is Use_Setting : Boolean := False); -- Load the unit whose Id is given if not already loaded. The unit is -- loaded, analyzed, and added to the WITH list, and the entry in - -- RT_Unit_Table is updated to reflect the load. The second parameter - -- indicates the initial setting for the Is_Potentially_Use_Visible + -- RT_Unit_Table is updated to reflect the load. Use_Setting is used + -- to indicate the initial setting for the Is_Potentially_Use_Visible -- flag of the entity for the loaded unit (if it is indeed loaded). -- A value of False means nothing special need be done. A value of -- True indicates that this flag must be set to True. It is needed @@ -1052,7 +1052,9 @@ package body Rtsfind is function RTU_Loaded (U : RTU_Id) return Boolean is begin - return Present (RT_Unit_Table (U).Entity); + return True and Present (RT_Unit_Table (U).Entity); + -- Temp kludge, return True, deals with bug of loading unit with + -- WITH not being registered as a proper rtsfind load ??? end RTU_Loaded; -------------------- diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 1f8bcab95da..0ec821cceba 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -450,6 +450,13 @@ package Rtsfind is RE_List_Controller, -- Ada.Finalization.List_Controller RE_Interrupt_ID, -- Ada.Interrupts + RE_Is_Reserved, -- Ada.Interrupts + RE_Is_Attached, -- Ada.Interrupts + RE_Current_Handler, -- Ada.Interrupts + RE_Attach_Handler, -- Ada.Interrupts + RE_Exchange_Handler, -- Ada.Interrupts + RE_Detach_Handler, -- Ada.Interrupts + RE_Reference, -- Ada.Interrupts RE_Names, -- Ada.Interupts.Names @@ -1522,6 +1529,13 @@ package Rtsfind is RE_List_Controller => Ada_Finalization_List_Controller, RE_Interrupt_ID => Ada_Interrupts, + RE_Is_Reserved => Ada_Interrupts, + RE_Is_Attached => Ada_Interrupts, + RE_Current_Handler => Ada_Interrupts, + RE_Attach_Handler => Ada_Interrupts, + RE_Exchange_Handler => Ada_Interrupts, + RE_Detach_Handler => Ada_Interrupts, + RE_Reference => Ada_Interrupts, RE_Names => Ada_Interrupts_Names, diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb index 39860017d7b..5210c9eee7a 100644 --- a/gcc/ada/s-interr.adb +++ b/gcc/ada/s-interr.adb @@ -305,9 +305,8 @@ package body System.Interrupts is -- Bind_Interrupt_To_Entry -- ----------------------------- - -- This procedure raises a Program_Error if it tries to - -- bind an interrupt to which an Entry or a Procedure is - -- already bound. + -- This procedure raises a Program_Error if it tries to bind an + -- interrupt to which an Entry or a Procedure is already bound. procedure Bind_Interrupt_To_Entry (T : Task_Id; @@ -315,7 +314,7 @@ package body System.Interrupts is Int_Ref : System.Address) is Interrupt : constant Interrupt_ID := - Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); + Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); begin if Is_Reserved (Interrupt) then @@ -324,7 +323,6 @@ package body System.Interrupts is end if; Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); - end Bind_Interrupt_To_Entry; --------------------- @@ -383,7 +381,6 @@ package body System.Interrupts is end if; Interrupt_Manager.Detach_Handler (Interrupt, Static); - end Detach_Handler; ------------------------------ @@ -404,8 +401,8 @@ package body System.Interrupts is -- previous handler's binding status (ie. do not care if it is a -- dynamic or static handler). - -- This option is needed so that during the finalization of a PO, we - -- can detach handlers attached through pragma Attach_Handler. + -- This option is needed so that during the finalization of a PO, + -- we can detach handlers attached through pragma Attach_Handler. procedure Exchange_Handler (Old_Handler : out Parameterless_Handler; @@ -421,12 +418,11 @@ package body System.Interrupts is Interrupt_Manager.Exchange_Handler (Old_Handler, New_Handler, Interrupt, Static); - end Exchange_Handler; - ---------------- - -- Finalize -- - ---------------- + -------------- + -- Finalize -- + -------------- procedure Finalize (Object : in out Static_Interrupt_Protection) is begin @@ -451,7 +447,7 @@ package body System.Interrupts is -- Has_Interrupt_Or_Attach_Handler -- ------------------------------------- - -- Need comments as to why these always return True + -- Need comments as to why these always return True ??? function Has_Interrupt_Or_Attach_Handler (Object : access Dynamic_Interrupt_Protection) return Boolean @@ -602,7 +598,6 @@ package body System.Interrupts is end loop; return False; - end Is_Registered; ----------------- @@ -804,7 +799,6 @@ package body System.Interrupts is else IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); end if; - end Unbind_Handler; -------------------------------- @@ -832,6 +826,7 @@ package body System.Interrupts is -- status of the current_Handler. if not Static and then User_Handler (Interrupt).Static then + -- Tries to detach a static Interrupt Handler. -- raise a program error. @@ -854,7 +849,6 @@ package body System.Interrupts is if Old_Handler /= null then Unbind_Handler (Interrupt); end if; - end Unprotected_Detach_Handler; ---------------------------------- @@ -866,7 +860,8 @@ package body System.Interrupts is New_Handler : Parameterless_Handler; Interrupt : Interrupt_ID; Static : Boolean; - Restoration : Boolean := False) is + Restoration : Boolean := False) + is begin if User_Entry (Interrupt).T /= Null_Task then @@ -951,7 +946,6 @@ package body System.Interrupts is if Old_Handler = null then Bind_Handler (Interrupt); end if; - end Unprotected_Exchange_Handler; -- Start of processing for Interrupt_Manager @@ -1081,6 +1075,7 @@ package body System.Interrupts is -- Place Task_Id info in Server_ID array. if Server_ID (Interrupt) = Null_Task then + -- When a new Server_Task is created, it should have its -- signal mask set to the All_Tasks_Mask. @@ -1100,6 +1095,7 @@ package body System.Interrupts is for J in Interrupt_ID'Range loop if not Is_Reserved (J) then if User_Entry (J).T = T then + -- The interrupt should no longer be ingnored if -- it was ever ignored. @@ -1111,7 +1107,7 @@ package body System.Interrupts is end if; end loop; - -- Indicate in ATCB that no Interrupt Entries are attached. + -- Indicate in ATCB that no Interrupt Entries are attached T.Interrupt_Entry := False; end Detach_Interrupt_Entries; @@ -1133,10 +1129,10 @@ package body System.Interrupts is if User_Handler (Interrupt).H /= null or else User_Entry (Interrupt).T /= Null_Task then - -- This is the case where the Server_Task is waiting on - -- "sigwait." Wake it up by sending an - -- Abort_Task_Interrupt so that the Server_Task waits on - -- Cond. + -- This is the case where the Server_Task is waiting + -- on "sigwait." Wake it up by sending an + -- Abort_Task_Interrupt so that the Server_Task + -- waits on Cond. POP.Abort_Task (Server_ID (Interrupt)); @@ -1166,6 +1162,7 @@ package body System.Interrupts is then -- No handler is attached. Unmask the Interrupt so that -- the default action can be carried out. + IMOP.Thread_Unblock_Interrupt (IMNG.Interrupt_ID (Interrupt)); @@ -1174,6 +1171,7 @@ package body System.Interrupts is -- since it was being blocked and an Interrupt Hander or -- an Entry was there. Wake it up and let it change -- it place of waiting according to its new state. + POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Blocked_Interrupt_Sleep); end if; @@ -1356,69 +1354,78 @@ package body System.Interrupts is POP.Write_Lock (Self_ID); else - pragma Assert (Ret_Interrupt = Interrupt); - if Single_Lock then POP.Lock_RTS; end if; POP.Write_Lock (Self_ID); - -- Even though we have received an Interrupt the status may - -- have changed already before we got the Self_ID lock above. - -- Therefore we make sure a Handler or an Entry is still - -- there and make appropriate call. - -- If there is no calls to make we need to regenerate the - -- Interrupt in order not to lose it. + if Ret_Interrupt /= Interrupt then - if User_Handler (Interrupt).H /= null then - Tmp_Handler := User_Handler (Interrupt).H; + -- On some systems (e.g. recent linux kernels), sigwait + -- may return unexpectedly (with errno set to EINTR). - -- RTS calls should not be made with self being locked. + null; - POP.Unlock (Self_ID); + else + -- Even though we have received an Interrupt the status may + -- have changed already before we got the Self_ID lock above + -- Therefore we make sure a Handler or an Entry is still + -- there and make appropriate call. - if Single_Lock then - POP.Unlock_RTS; - end if; + -- If there is no calls to make we need to regenerate the + -- Interrupt in order not to lose it. - Tmp_Handler.all; + if User_Handler (Interrupt).H /= null then + Tmp_Handler := User_Handler (Interrupt).H; - if Single_Lock then - POP.Lock_RTS; - end if; + -- RTS calls should not be made with self being locked. - POP.Write_Lock (Self_ID); + POP.Unlock (Self_ID); - elsif User_Entry (Interrupt).T /= Null_Task then - Tmp_ID := User_Entry (Interrupt).T; - Tmp_Entry_Index := User_Entry (Interrupt).E; + if Single_Lock then + POP.Unlock_RTS; + end if; - -- RTS calls should not be made with self being locked. + Tmp_Handler.all; - if Single_Lock then - POP.Unlock_RTS; - end if; + if Single_Lock then + POP.Lock_RTS; + end if; - POP.Unlock (Self_ID); + POP.Write_Lock (Self_ID); - System.Tasking.Rendezvous.Call_Simple - (Tmp_ID, Tmp_Entry_Index, System.Null_Address); + elsif User_Entry (Interrupt).T /= Null_Task then + Tmp_ID := User_Entry (Interrupt).T; + Tmp_Entry_Index := User_Entry (Interrupt).E; - POP.Write_Lock (Self_ID); + -- RTS calls should not be made with self being locked. - if Single_Lock then - POP.Lock_RTS; - end if; + if Single_Lock then + POP.Unlock_RTS; + end if; - else - -- This is a situation that this task wake up - -- receiving an Interrupt and before it get the lock - -- the Interrupt is blocked. We do not - -- want to lose the interrupt in this case so that - -- regenerate the Interrupt to process level; + POP.Unlock (Self_ID); + + System.Tasking.Rendezvous.Call_Simple + (Tmp_ID, Tmp_Entry_Index, System.Null_Address); - IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt)); + POP.Write_Lock (Self_ID); + + if Single_Lock then + POP.Lock_RTS; + end if; + + else + -- This is a situation that this task wakes up receiving + -- an Interrupt and before it gets the lock the Interrupt + -- is blocked. We do not want to lose the interrupt in + -- this case so we regenerate the Interrupt to process + -- level. + + IMOP.Interrupt_Self_Process + (IMNG.Interrupt_ID (Interrupt)); + end if; end if; end if; end if; @@ -1433,30 +1440,30 @@ package body System.Interrupts is -- Undefer abort here to allow a window for this task -- to be aborted at the time of system shutdown. + end loop; end Server_Task; -- Elaboration code for package System.Interrupts begin - -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent. Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); - -- During the elaboration of this package body we want RTS to - -- inherit the interrupt mask from the Environment Task. + -- During the elaboration of this package body we want the RTS + -- to inherit the interrupt mask from the Environment Task. - -- The Environment Task should have gotten its mask from + -- The environment task should have gotten its mask from -- the enclosing process during the RTS start up. (See - -- in s-inmaop.adb). Pass the Interrupt_Mask of the Environment - -- task to the Interrupt_Manager. + -- processing in s-inmaop.adb). Pass the Interrupt_Mask + -- of the environment task to the Interrupt_Manager. -- Note : At this point we know that all tasks (including -- RTS internal servers) are masked for non-reserved signals -- (see s-taprop.adb). Only the Interrupt_Manager will have - -- masks set up differently inheriting the original Environment - -- Task's mask. + -- masks set up differently inheriting the original environment + -- task's mask. Interrupt_Manager.Initialize (IMOP.Environment_Mask); end System.Interrupts; diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index ccd082debcc..1524cbf97e6 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -347,20 +347,22 @@ package Sem is -- Handling of Check Suppression -- ----------------------------------- - -- There are two kinds of suppress checks, scope based suppress checks - -- (from initial command line arguments, or from Suppress pragmas not - -- including an entity name). The scope based suppress checks are recorded + -- There are two kinds of suppress checks: scope based suppress checks, + -- and entity based suppress checks. + + -- Scope based suppress chems (from initial command line arguments, + -- or from Suppress pragmas not including an entity name) are recorded -- in the Sem.Supress variable, and all that is necessary is to save the -- state of this variable on scope entry, and restore it on scope exit. - -- The other kind of suppress check is entity based suppress checks, from - -- Suppress pragmas giving an Entity_Id. These are handled as follows. If - -- a suppress or unsuppress pragma is encountered for a given entity, then - -- the flag Checks_May_Be_Suppressed is set in the entity and an entry is - -- made in either the Local_Entity_Suppress table (case of pragma that - -- appears in other than a package spec), or in the Global_Entity_Suppress - -- table (case of pragma that appears in a package spec, which is by the - -- rule of RM 11.5(7) applicable throughout the life of the entity). + -- Entity based suppress checks, from Suppress pragmas giving an Entity_Id, + -- are handled as follows. If a suppress or unsuppress pragma is + -- encountered for a given entity, then the flag Checks_May_Be_Suppressed + -- is set in the entity and an entry is made in either the + -- Local_Entity_Suppress table (case of pragma that appears in other than + -- a package spec), or in the Global_Entity_Suppress table (case of pragma + -- that appears in a package spec, which is by the rule of RM 11.5(7) + -- applicable throughout the life of the entity). -- If the Checks_May_Be_Suppressed flag is set in an entity then the -- procedure is to search first the local and then the global suppress diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 7684845103a..6d4e25d2d7f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3636,12 +3636,17 @@ package body Sem_Ch12 is -- Common error routine for mismatch between the parameters of -- the actual instance and those of the formal package. - function Same_Instantiated_Entity (E1, E2 : Entity_Id) return Boolean; + function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean; -- The formal may come from a nested formal package, and the actual -- may have been constant-folded. To determine whether the two denote -- the same entity we may have to traverse several definitions to -- recover the ultimate entity that they refer to. + function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean; + -- Similarly, if the formal comes from a nested formal package, the + -- actual may designate the formal through multiple renamings, which + -- have to be followed to determine the original variable in question. + -------------------- -- Check_Mismatch -- -------------------- @@ -3655,13 +3660,14 @@ package body Sem_Ch12 is end if; end Check_Mismatch; - ------------------------------ - -- Same_Instantiated_Entity -- - ------------------------------ + -------------------------------- + -- Same_Instantiated_Constant -- + -------------------------------- - function Same_Instantiated_Entity (E1, E2 : Entity_Id) return Boolean is + function Same_Instantiated_Constant + (E1, E2 : Entity_Id) return Boolean + is Ent : Entity_Id; - begin Ent := E2; while Present (Ent) loop @@ -3689,7 +3695,43 @@ package body Sem_Ch12 is end loop; return False; - end Same_Instantiated_Entity; + end Same_Instantiated_Constant; + + -------------------------------- + -- Same_Instantiated_Variable -- + -------------------------------- + + function Same_Instantiated_Variable + (E1, E2 : Entity_Id) return Boolean + is + function Original_Entity (E : Entity_Id) return Entity_Id; + -- Follow chain of renamings to the ultimate ancestor. + + --------------------- + -- Original_Entity -- + --------------------- + + function Original_Entity (E : Entity_Id) return Entity_Id is + Orig : Entity_Id; + + begin + Orig := E; + while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration + and then Present (Renamed_Object (Orig)) + and then Is_Entity_Name (Renamed_Object (Orig)) + loop + Orig := Entity (Renamed_Object (Orig)); + end loop; + + return Orig; + end Original_Entity; + + -- Start of processing for Same_Instantiated_Variable + + begin + return Ekind (E1) = Ekind (E2) + and then Original_Entity (E1) = Original_Entity (E2); + end Same_Instantiated_Variable; -- Start of processing for Check_Formal_Package_Instance @@ -3768,13 +3810,10 @@ package body Sem_Ch12 is if Is_Entity_Name (Expr2) then if Entity (Expr1) = Entity (Expr2) then null; - - elsif - Same_Instantiated_Entity (Entity (Expr1), Entity (Expr2)) - then - null; else - Check_Mismatch (True); + Check_Mismatch + (not Same_Instantiated_Constant + (Entity (Expr1), Entity (Expr2))); end if; else Check_Mismatch (True); @@ -3783,7 +3822,7 @@ package body Sem_Ch12 is elsif Is_Entity_Name (Original_Node (Expr1)) and then Is_Entity_Name (Expr2) and then - Same_Instantiated_Entity + Same_Instantiated_Constant (Entity (Original_Node (Expr1)), Entity (Expr2)) then null; @@ -3795,9 +3834,10 @@ package body Sem_Ch12 is Check_Mismatch (True); end if; - elsif Ekind (E1) = E_Variable - or else Ekind (E1) = E_Package - then + elsif Ekind (E1) = E_Variable then + Check_Mismatch (not Same_Instantiated_Variable (E1, E2)); + + elsif Ekind (E1) = E_Package then Check_Mismatch (Ekind (E1) /= Ekind (E2) or else Renamed_Object (E1) /= Renamed_Object (E2)); @@ -7350,7 +7390,15 @@ package body Sem_Ch12 is if Nkind (Gen_Body) = N_Subprogram_Body_Stub then -- Either body is not present, or context is non-expanding, as - -- when compiling a subunit. Mark the instance as completed. + -- when compiling a subunit. Mark the instance as completed, and + -- diagnose a missing body when needed. + + if Expander_Active + and then Operating_Mode = Generate_Code + then + Error_Msg_N + ("missing proper body for instantiation", Gen_Body); + end if; Set_Has_Completion (Anon_Id); return; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 8722b77692d..48169d94f12 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4361,6 +4361,7 @@ package body Sem_Ch4 is -- truly hidden. type Operand_Position is (First_Op, Second_Op); + Univ_Type : constant Entity_Id := Universal_Interpretation (N); procedure Remove_Address_Interpretations (Op : Operand_Position); -- Ambiguities may arise when the operands are literal and the @@ -4451,6 +4452,25 @@ package body Sem_Ch4 is Remove_Interp (I); end if; + Get_Next_Interp (I, It); + end loop; + + elsif Is_Overloaded (N) + and then Present (Univ_Type) + then + -- If both operands have a universal interpretation, + -- select the predefined operator and discard others. + + Get_First_Interp (N, I, It); + + while Present (It.Nam) loop + if Scope (It.Nam) = Standard_Standard then + Set_Etype (N, Univ_Type); + Set_Entity (N, It.Nam); + Set_Is_Overloaded (N, False); + exit; + end if; + Get_Next_Interp (I, It); end loop; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index d3ee90e982f..a48a6ca0479 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -561,6 +561,12 @@ package body Sem_Prag is -- argument has the right form then the Mechanism field of Ent is -- set appropriately. + procedure Set_Ravenscar_Profile (N : Node_Id); + -- Activate the set of configuration pragmas and restrictions that + -- make up the Ravenscar Profile. N is the corresponding pragma + -- node, which is used for error messages on any constructs + -- that violate the profile. + -------------------------- -- Check_Ada_83_Warning -- -------------------------- @@ -3257,8 +3263,7 @@ package body Sem_Prag is Val : Uint; procedure Set_Warning (R : All_Restrictions); - -- If this is a Restriction_Warnings pragma, set warning flag, - -- otherwise flag gets cleared. + -- If this is a Restriction_Warnings pragma, set warning flag ----------------- -- Set_Warning -- @@ -3266,8 +3271,9 @@ package body Sem_Prag is procedure Set_Warning (R : All_Restrictions) is begin - Restriction_Warnings (R) := - Prag_Id = Pragma_Restriction_Warnings; + if Prag_Id = Pragma_Restriction_Warnings then + Restriction_Warnings (R) := True; + end if; end Set_Warning; -- Start of processing for Process_Restrictions_Or_Restriction_Warnings @@ -3821,6 +3827,70 @@ package body Sem_Prag is end Set_Mechanism_Value; + --------------------------- + -- Set_Ravenscar_Profile -- + --------------------------- + + -- The tasks to be done here are + + -- Set required policies + + -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) + -- pragma Locking_Policy (Ceiling_Locking) + + -- Set Detect_Blocking mode ??? + + -- Set required restrictions (see Restrict.Set_Ravenscar for details) + + procedure Set_Ravenscar_Profile (N : Node_Id) is + begin + -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) + + if Task_Dispatching_Policy /= ' ' + and then Task_Dispatching_Policy /= 'F' + then + Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; + Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); + + -- Set the FIFO_Within_Priorities policy, but always + -- preserve System_Location since we like the error + -- message with the run time name. + + else + Task_Dispatching_Policy := 'F'; + + if Task_Dispatching_Policy_Sloc /= System_Location then + Task_Dispatching_Policy_Sloc := Loc; + end if; + end if; + + -- pragma Locking_Policy (Ceiling_Locking) + + if Locking_Policy /= ' ' + and then Locking_Policy /= 'C' + then + Error_Msg_Sloc := Locking_Policy_Sloc; + Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); + + -- Set the Ceiling_Locking policy, but always preserve + -- System_Location since we like the error message with the + -- run time name. + + else + Locking_Policy := 'C'; + + if Locking_Policy_Sloc /= System_Location then + Locking_Policy_Sloc := Loc; + end if; + end if; + + -- ??? Detect_Blocking + + -- Set the corresponding restrictions + + Set_Ravenscar (N); + end Set_Ravenscar_Profile; + -- Start of processing for Analyze_Pragma begin @@ -8005,13 +8075,12 @@ package body Sem_Prag is Check_Arg_Count (1); Check_Valid_Configuration_Pragma; Check_No_Identifiers; - Set_Ravenscar (N); declare Argx : constant Node_Id := Get_Pragma_Arg (Arg1); begin if Chars (Argx) = Name_Ravenscar then - Set_Ravenscar (N); + Set_Ravenscar_Profile (N); else Error_Pragma_Arg ("& is not a valid profile", Argx); end if; @@ -8481,7 +8550,7 @@ package body Sem_Prag is GNAT_Pragma; Check_Arg_Count (0); Check_Valid_Configuration_Pragma; - Set_Ravenscar (N); + Set_Ravenscar_Profile (N); ------------------------- -- Restricted_Run_Time -- @@ -9950,6 +10019,7 @@ package body Sem_Prag is -- Start of prorcessing for Is_Config_Static_String begin + Name_Len := 0; return Add_Config_Static_String (Arg); end Is_Config_Static_String; @@ -9965,6 +10035,7 @@ package body Sem_Prag is -- indicates that appearence in that parameter position is significant. Sig_Flags : constant array (Pragma_Id) of Int := + (Pragma_AST_Entry => -1, Pragma_Abort_Defer => -1, Pragma_Ada_83 => -1, @@ -10095,7 +10166,7 @@ package body Sem_Prag is Pragma_Thread_Body => +2, Pragma_Time_Slice => -1, Pragma_Title => -1, - Pragma_Unchecked_Union => -1, + Pragma_Unchecked_Union => 0, Pragma_Unimplemented_Unit => -1, Pragma_Universal_Data => -1, Pragma_Unreferenced => -1, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 9eb9af0b388..446a834bed5 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3456,7 +3456,9 @@ package body Sem_Util is -- Done if no more derivations to check - elsif T = T1 then + elsif T = T1 + or else T = Etyp + then return False; -- Following test catches error cases resulting from prev errors @@ -3471,11 +3473,7 @@ package body Sem_Util is return False; end if; - -- Return if no further entries to check - - if T = Base_Type (T1) or else T = T1 then - return False; - end if; + T := Base_Type (Etyp); end loop; end if; @@ -3927,7 +3925,9 @@ package body Sem_Util is return Attribute_Name (N) = Name_Input; when N_Selected_Component => - return Is_Object_Reference (Selector_Name (N)); + return + Is_Object_Reference (Selector_Name (N)) + and then Is_Object_Reference (Prefix (N)); when N_Explicit_Dereference => return True; diff --git a/gcc/ada/symbols-vms-alpha.adb b/gcc/ada/symbols-vms-alpha.adb new file mode 100644 index 00000000000..c623e42b383 --- /dev/null +++ b/gcc/ada/symbols-vms-alpha.adb @@ -0,0 +1,743 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y M B O L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VMS version of this package + +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Sequential_IO; +with Ada.Text_IO; use Ada.Text_IO; + +package body Symbols is + + Case_Sensitive : constant String := "case_sensitive="; + Symbol_Vector : constant String := "SYMBOL_VECTOR=("; + Equal_Data : constant String := "=DATA)"; + Equal_Procedure : constant String := "=PROCEDURE)"; + Gsmatch : constant String := "gsmatch=equal,"; + + Symbol_File_Name : String_Access := null; + -- Name of the symbol file + + Sym_Policy : Policy := Autonomous; + -- The symbol policy. Set by Initialize + + Major_ID : Integer := 1; + -- The Major ID. May be modified by Initialize if Library_Version is + -- specified or if it is read from the reference symbol file. + + Soft_Major_ID : Boolean := True; + -- False if library version is specified in procedure Initialize. + -- When True, Major_ID may be modified if found in the reference symbol + -- file. + + Minor_ID : Natural := 0; + -- The Minor ID. May be modified if read from the reference symbol file + + Soft_Minor_ID : Boolean := True; + -- False if symbol policy is Autonomous, if library version is specified + -- in procedure Initialize and is not the same as the major ID read from + -- the reference symbol file. When True, Minor_ID may be increased in + -- Compliant symbol policy. + + subtype Byte is Character; + -- Object files are stream of bytes, but some of these bytes, those for + -- the names of the symbols, are ASCII characters. + + package Byte_IO is new Ada.Sequential_IO (Byte); + use Byte_IO; + + type Number is mod 2**16; + -- 16 bits unsigned number for number of characters + + GSD : constant Number := 10; + -- Code for the Global Symbol Definition section + + C_SYM : constant Number := 1; + -- Code for a Symbol subsection + + V_DEF_Mask : constant Number := 2**1; + V_NORM_Mask : constant Number := 2**6; + + File : Byte_IO.File_Type; + -- Each object file is read as a stream of bytes (characters) + + B : Byte; + + Number_Of_Characters : Natural := 0; + -- The number of characters of each section + + -- The following variables are used by procedure Process when reading an + -- object file. + + Code : Number := 0; + Length : Natural := 0; + + Dummy : Number; + + Nchars : Natural := 0; + Flags : Number := 0; + + Symbol : String (1 .. 255); + LSymb : Natural; + + function Equal (Left, Right : Symbol_Data) return Boolean; + -- Test for equality of symbols + + procedure Get (N : out Number); + -- Read two bytes from the object file LSB first as unsigned 16 bit number + + procedure Get (N : out Natural); + -- Read two bytes from the object file, LSByte first, as a Natural + + + function Image (N : Integer) return String; + -- Returns the image of N, without the initial space + + ----------- + -- Equal -- + ----------- + + function Equal (Left, Right : Symbol_Data) return Boolean is + begin + return Left.Name /= null and then + Right.Name /= null and then + Left.Name.all = Right.Name.all and then + Left.Kind = Right.Kind and then + Left.Present = Right.Present; + end Equal; + + --------- + -- Get -- + --------- + + procedure Get (N : out Number) is + C : Byte; + LSByte : Number; + begin + Read (File, C); + LSByte := Byte'Pos (C); + Read (File, C); + N := LSByte + (256 * Byte'Pos (C)); + end Get; + + procedure Get (N : out Natural) is + Result : Number; + begin + Get (Result); + N := Natural (Result); + end Get; + + ----------- + -- Image -- + ----------- + + function Image (N : Integer) return String is + Result : constant String := N'Img; + begin + if Result (Result'First) = ' ' then + return Result (Result'First + 1 .. Result'Last); + + else + return Result; + end if; + end Image; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Symbol_File : String; + Reference : String; + Symbol_Policy : Policy; + Quiet : Boolean; + Version : String; + Success : out Boolean) + is + File : Ada.Text_IO.File_Type; + Line : String (1 .. 1_000); + Last : Natural; + + begin + -- Record the symbol file name + + Symbol_File_Name := new String'(Symbol_File); + + -- Record the policy + + Sym_Policy := Symbol_Policy; + + -- Record the version (Major ID) + + if Version = "" then + Major_ID := 1; + Soft_Major_ID := True; + + else + begin + Major_ID := Integer'Value (Version); + Soft_Major_ID := False; + + if Major_ID <= 0 then + raise Constraint_Error; + end if; + + exception + when Constraint_Error => + if not Quiet then + Put_Line ("Version """ & Version & """ is illegal."); + Put_Line ("On VMS, version must be a positive number"); + end if; + + Success := False; + return; + end; + end if; + + Minor_ID := 0; + Soft_Minor_ID := Sym_Policy /= Autonomous; + + -- Empty the symbol tables + + Symbol_Table.Set_Last (Original_Symbols, 0); + Symbol_Table.Set_Last (Complete_Symbols, 0); + + -- Assume that everything will be fine + + Success := True; + + -- If policy is not autonomous, attempt to read the reference file + + if Sym_Policy /= Autonomous then + begin + Open (File, In_File, Reference); + + exception + when Ada.Text_IO.Name_Error => + return; + + when X : others => + if not Quiet then + Put_Line ("could not open """ & Reference & """"); + Put_Line (Exception_Message (X)); + end if; + + Success := False; + return; + end; + + -- Read line by line + + while not End_Of_File (File) loop + Get_Line (File, Line, Last); + + -- Ignore empty lines + + if Last = 0 then + null; + + -- Ignore lines starting with "case_sensitive=" + + elsif Last > Case_Sensitive'Length + and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive + then + null; + + -- Line starting with "SYMBOL_VECTOR=(" + + elsif Last > Symbol_Vector'Length + and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector + then + + -- SYMBOL_VECTOR=(=DATA) + + if Last > Symbol_Vector'Length + Equal_Data'Length and then + Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data + then + Symbol_Table.Increment_Last (Original_Symbols); + Original_Symbols.Table + (Symbol_Table.Last (Original_Symbols)) := + (Name => + new String'(Line (Symbol_Vector'Length + 1 .. + Last - Equal_Data'Length)), + Kind => Data, + Present => True); + + -- SYMBOL_VECTOR=(=PROCEDURE) + + elsif Last > Symbol_Vector'Length + Equal_Procedure'Length + and then + Line (Last - Equal_Procedure'Length + 1 .. Last) = + Equal_Procedure + then + Symbol_Table.Increment_Last (Original_Symbols); + Original_Symbols.Table + (Symbol_Table.Last (Original_Symbols)) := + (Name => + new String'(Line (Symbol_Vector'Length + 1 .. + Last - Equal_Procedure'Length)), + Kind => Proc, + Present => True); + + -- Anything else is incorrectly formatted + + else + if not Quiet then + Put_Line ("symbol file """ & Reference & + """ is incorrectly formatted:"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + end if; + + -- Lines with "gsmatch=equal,, + + elsif Last > Gsmatch'Length + and then Line (1 .. Gsmatch'Length) = Gsmatch + then + declare + Start : Positive := Gsmatch'Length + 1; + Finish : Positive := Start; + OK : Boolean := True; + ID : Integer; + + begin + loop + if Line (Finish) not in '0' .. '9' + or else Finish >= Last - 1 + then + OK := False; + exit; + end if; + + exit when Line (Finish + 1) = ','; + + Finish := Finish + 1; + end loop; + + if OK then + ID := Integer'Value (Line (Start .. Finish)); + OK := ID /= 0; + + -- If Soft_Major_ID is True, it means that + -- Library_Version was not specified. + + if Soft_Major_ID then + Major_ID := ID; + + -- If the Major ID in the reference file is different + -- from the Library_Version, then the Minor ID will be 0 + -- because there is no point in taking the Minor ID in + -- the reference file, or incrementing it. So, we set + -- Soft_Minor_ID to False, so that we don't modify + -- the Minor_ID later. + + elsif Major_ID /= ID then + Soft_Minor_ID := False; + end if; + + Start := Finish + 2; + Finish := Start; + + loop + if Line (Finish) not in '0' .. '9' then + OK := False; + exit; + end if; + + exit when Finish = Last; + + Finish := Finish + 1; + end loop; + + -- Only set Minor_ID if Soft_Minor_ID is True (see above) + + if OK and then Soft_Minor_ID then + Minor_ID := Integer'Value (Line (Start .. Finish)); + end if; + end if; + + -- If OK is not True, that means the line is not correctly + -- formatted. + + if not OK then + if not Quiet then + Put_Line ("symbol file """ & Reference & + """ is incorrectly formatted"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + end if; + end; + + -- Anything else is incorrectly formatted + + else + if not Quiet then + Put_Line ("unexpected line in symbol file """ & + Reference & """"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + end if; + end loop; + + Close (File); + end if; + end Initialize; + + ------------- + -- Process -- + ------------- + + procedure Process + (Object_File : String; + Success : out Boolean) + is + begin + -- Open the object file with Byte_IO. Return with Success = False if + -- this fails. + + begin + Open (File, In_File, Object_File); + exception + when others => + Put_Line + ("*** Unable to open object file """ & Object_File & """"); + Success := False; + return; + end; + + -- Assume that the object file has a correct format + + Success := True; + + -- Get the different sections one by one from the object file + + while not End_Of_File (File) loop + + Get (Code); + Get (Number_Of_Characters); + Number_Of_Characters := Number_Of_Characters - 4; + + -- If this is not a Global Symbol Definition section, skip to the + -- next section. + + if Code /= GSD then + + for J in 1 .. Number_Of_Characters loop + Read (File, B); + end loop; + + else + + -- Skip over the next 4 bytes + + Get (Dummy); + Get (Dummy); + Number_Of_Characters := Number_Of_Characters - 4; + + -- Get each subsection in turn + + loop + Get (Code); + Get (Nchars); + Get (Dummy); + Get (Flags); + Number_Of_Characters := Number_Of_Characters - 8; + Nchars := Nchars - 8; + + -- If this is a symbol and the V_DEF flag is set, get the + -- symbol. + + if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then + -- First, reach the symbol length + + for J in 1 .. 25 loop + Read (File, B); + Nchars := Nchars - 1; + Number_Of_Characters := Number_Of_Characters - 1; + end loop; + + Length := Byte'Pos (B); + LSymb := 0; + + -- Get the symbol characters + + for J in 1 .. Nchars loop + Read (File, B); + Number_Of_Characters := Number_Of_Characters - 1; + if Length > 0 then + LSymb := LSymb + 1; + Symbol (LSymb) := B; + Length := Length - 1; + end if; + end loop; + + -- Create the new Symbol + + declare + S_Data : Symbol_Data; + begin + S_Data.Name := new String'(Symbol (1 .. LSymb)); + + -- The symbol kind (Data or Procedure) depends on the + -- V_NORM flag. + + if (Flags and V_NORM_Mask) = 0 then + S_Data.Kind := Data; + + else + S_Data.Kind := Proc; + end if; + + -- Put the new symbol in the table + + Symbol_Table.Increment_Last (Complete_Symbols); + Complete_Symbols.Table + (Symbol_Table.Last (Complete_Symbols)) := S_Data; + end; + + else + -- As it is not a symbol subsection, skip to the next + -- subsection. + + for J in 1 .. Nchars loop + Read (File, B); + Number_Of_Characters := Number_Of_Characters - 1; + end loop; + end if; + + -- Exit the GSD section when number of characters reaches 0 + + exit when Number_Of_Characters = 0; + end loop; + end if; + end loop; + + -- The object file has been processed, close it + + Close (File); + + exception + -- For any exception, output an error message, close the object file + -- and return with Success = False. + + when X : others => + Put_Line ("unexpected exception raised while processing """ + & Object_File & """"); + Put_Line (Exception_Information (X)); + Close (File); + Success := False; + end Process; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize + (Quiet : Boolean; + Success : out Boolean) + is + File : Ada.Text_IO.File_Type; + -- The symbol file + + S_Data : Symbol_Data; + -- A symbol + + Cur : Positive := 1; + -- Most probable index in the Complete_Symbols of the current symbol + -- in Original_Symbol. + + Found : Boolean; + + begin + -- Nothing to be done if Initialize has never been called + + if Symbol_File_Name = null then + Success := False; + + else + + -- First find if the symbols in the reference symbol file are also + -- in the object files. Note that this is not done if the policy is + -- Autonomous, because no reference symbol file has been read. + + -- Expect the first symbol in the symbol file to also be the first + -- in Complete_Symbols. + + Cur := 1; + + for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop + S_Data := Original_Symbols.Table (Index_1); + Found := False; + + First_Object_Loop : + for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop + if Equal (S_Data, Complete_Symbols.Table (Index_2)) then + Cur := Index_2 + 1; + Complete_Symbols.Table (Index_2).Present := False; + Found := True; + exit First_Object_Loop; + end if; + end loop First_Object_Loop; + + -- If the symbol could not be found between Cur and Last, try + -- before Cur. + + if not Found then + Second_Object_Loop : + for Index_2 in 1 .. Cur - 1 loop + if Equal (S_Data, Complete_Symbols.Table (Index_2)) then + Cur := Index_2 + 1; + Complete_Symbols.Table (Index_2).Present := False; + Found := True; + exit Second_Object_Loop; + end if; + end loop Second_Object_Loop; + end if; + + -- If the symbol is not found, mark it as such in the table + + if not Found then + if (not Quiet) or else Sym_Policy = Controlled then + Put_Line ("symbol """ & S_Data.Name.all & + """ is no longer present in the object files"); + end if; + + if Sym_Policy = Controlled then + Success := False; + return; + + elsif Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + + Original_Symbols.Table (Index_1).Present := False; + Free (Original_Symbols.Table (Index_1).Name); + + if Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + end if; + end loop; + + -- Append additional symbols, if any, to the Original_Symbols table + + for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop + S_Data := Complete_Symbols.Table (Index); + + if S_Data.Present then + + if Sym_Policy = Controlled then + Put_Line ("symbol """ & S_Data.Name.all & + """ is not in the reference symbol file"); + Success := False; + return; + + elsif Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + + Symbol_Table.Increment_Last (Original_Symbols); + Original_Symbols.Table (Symbol_Table.Last (Original_Symbols)) := + S_Data; + Complete_Symbols.Table (Index).Present := False; + end if; + end loop; + + -- Create the symbol file + + Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all); + + Put (File, Case_Sensitive); + Put_Line (File, "yes"); + + -- Put a line in the symbol file for each symbol in the symbol table + + for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop + if Original_Symbols.Table (Index).Present then + Put (File, Symbol_Vector); + Put (File, Original_Symbols.Table (Index).Name.all); + + if Original_Symbols.Table (Index).Kind = Data then + Put_Line (File, Equal_Data); + + else + Put_Line (File, Equal_Procedure); + end if; + + Free (Original_Symbols.Table (Index).Name); + end if; + end loop; + + Put (File, Case_Sensitive); + Put_Line (File, "NO"); + + -- Put the version IDs + + Put (File, Gsmatch); + Put (File, Image (Major_ID)); + Put (File, ','); + Put_Line (File, Image (Minor_ID)); + + -- And we are done + + Close (File); + + -- Reset both tables + + Symbol_Table.Set_Last (Original_Symbols, 0); + Symbol_Table.Set_Last (Complete_Symbols, 0); + + -- Clear the symbol file name + + Free (Symbol_File_Name); + + Success := True; + end if; + + exception + when X : others => + Put_Line ("unexpected exception raised while finalizing """ + & Symbol_File_Name.all & """"); + Put_Line (Exception_Information (X)); + Success := False; + end Finalize; + +end Symbols; diff --git a/gcc/ada/symbols-vms.adb b/gcc/ada/symbols-vms.adb deleted file mode 100644 index c623e42b383..00000000000 --- a/gcc/ada/symbols-vms.adb +++ /dev/null @@ -1,743 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y M B O L S -- --- -- --- B o d y -- --- -- --- Copyright (C) 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. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS version of this package - -with Ada.Exceptions; use Ada.Exceptions; -with Ada.Sequential_IO; -with Ada.Text_IO; use Ada.Text_IO; - -package body Symbols is - - Case_Sensitive : constant String := "case_sensitive="; - Symbol_Vector : constant String := "SYMBOL_VECTOR=("; - Equal_Data : constant String := "=DATA)"; - Equal_Procedure : constant String := "=PROCEDURE)"; - Gsmatch : constant String := "gsmatch=equal,"; - - Symbol_File_Name : String_Access := null; - -- Name of the symbol file - - Sym_Policy : Policy := Autonomous; - -- The symbol policy. Set by Initialize - - Major_ID : Integer := 1; - -- The Major ID. May be modified by Initialize if Library_Version is - -- specified or if it is read from the reference symbol file. - - Soft_Major_ID : Boolean := True; - -- False if library version is specified in procedure Initialize. - -- When True, Major_ID may be modified if found in the reference symbol - -- file. - - Minor_ID : Natural := 0; - -- The Minor ID. May be modified if read from the reference symbol file - - Soft_Minor_ID : Boolean := True; - -- False if symbol policy is Autonomous, if library version is specified - -- in procedure Initialize and is not the same as the major ID read from - -- the reference symbol file. When True, Minor_ID may be increased in - -- Compliant symbol policy. - - subtype Byte is Character; - -- Object files are stream of bytes, but some of these bytes, those for - -- the names of the symbols, are ASCII characters. - - package Byte_IO is new Ada.Sequential_IO (Byte); - use Byte_IO; - - type Number is mod 2**16; - -- 16 bits unsigned number for number of characters - - GSD : constant Number := 10; - -- Code for the Global Symbol Definition section - - C_SYM : constant Number := 1; - -- Code for a Symbol subsection - - V_DEF_Mask : constant Number := 2**1; - V_NORM_Mask : constant Number := 2**6; - - File : Byte_IO.File_Type; - -- Each object file is read as a stream of bytes (characters) - - B : Byte; - - Number_Of_Characters : Natural := 0; - -- The number of characters of each section - - -- The following variables are used by procedure Process when reading an - -- object file. - - Code : Number := 0; - Length : Natural := 0; - - Dummy : Number; - - Nchars : Natural := 0; - Flags : Number := 0; - - Symbol : String (1 .. 255); - LSymb : Natural; - - function Equal (Left, Right : Symbol_Data) return Boolean; - -- Test for equality of symbols - - procedure Get (N : out Number); - -- Read two bytes from the object file LSB first as unsigned 16 bit number - - procedure Get (N : out Natural); - -- Read two bytes from the object file, LSByte first, as a Natural - - - function Image (N : Integer) return String; - -- Returns the image of N, without the initial space - - ----------- - -- Equal -- - ----------- - - function Equal (Left, Right : Symbol_Data) return Boolean is - begin - return Left.Name /= null and then - Right.Name /= null and then - Left.Name.all = Right.Name.all and then - Left.Kind = Right.Kind and then - Left.Present = Right.Present; - end Equal; - - --------- - -- Get -- - --------- - - procedure Get (N : out Number) is - C : Byte; - LSByte : Number; - begin - Read (File, C); - LSByte := Byte'Pos (C); - Read (File, C); - N := LSByte + (256 * Byte'Pos (C)); - end Get; - - procedure Get (N : out Natural) is - Result : Number; - begin - Get (Result); - N := Natural (Result); - end Get; - - ----------- - -- Image -- - ----------- - - function Image (N : Integer) return String is - Result : constant String := N'Img; - begin - if Result (Result'First) = ' ' then - return Result (Result'First + 1 .. Result'Last); - - else - return Result; - end if; - end Image; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize - (Symbol_File : String; - Reference : String; - Symbol_Policy : Policy; - Quiet : Boolean; - Version : String; - Success : out Boolean) - is - File : Ada.Text_IO.File_Type; - Line : String (1 .. 1_000); - Last : Natural; - - begin - -- Record the symbol file name - - Symbol_File_Name := new String'(Symbol_File); - - -- Record the policy - - Sym_Policy := Symbol_Policy; - - -- Record the version (Major ID) - - if Version = "" then - Major_ID := 1; - Soft_Major_ID := True; - - else - begin - Major_ID := Integer'Value (Version); - Soft_Major_ID := False; - - if Major_ID <= 0 then - raise Constraint_Error; - end if; - - exception - when Constraint_Error => - if not Quiet then - Put_Line ("Version """ & Version & """ is illegal."); - Put_Line ("On VMS, version must be a positive number"); - end if; - - Success := False; - return; - end; - end if; - - Minor_ID := 0; - Soft_Minor_ID := Sym_Policy /= Autonomous; - - -- Empty the symbol tables - - Symbol_Table.Set_Last (Original_Symbols, 0); - Symbol_Table.Set_Last (Complete_Symbols, 0); - - -- Assume that everything will be fine - - Success := True; - - -- If policy is not autonomous, attempt to read the reference file - - if Sym_Policy /= Autonomous then - begin - Open (File, In_File, Reference); - - exception - when Ada.Text_IO.Name_Error => - return; - - when X : others => - if not Quiet then - Put_Line ("could not open """ & Reference & """"); - Put_Line (Exception_Message (X)); - end if; - - Success := False; - return; - end; - - -- Read line by line - - while not End_Of_File (File) loop - Get_Line (File, Line, Last); - - -- Ignore empty lines - - if Last = 0 then - null; - - -- Ignore lines starting with "case_sensitive=" - - elsif Last > Case_Sensitive'Length - and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive - then - null; - - -- Line starting with "SYMBOL_VECTOR=(" - - elsif Last > Symbol_Vector'Length - and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector - then - - -- SYMBOL_VECTOR=(=DATA) - - if Last > Symbol_Vector'Length + Equal_Data'Length and then - Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data - then - Symbol_Table.Increment_Last (Original_Symbols); - Original_Symbols.Table - (Symbol_Table.Last (Original_Symbols)) := - (Name => - new String'(Line (Symbol_Vector'Length + 1 .. - Last - Equal_Data'Length)), - Kind => Data, - Present => True); - - -- SYMBOL_VECTOR=(=PROCEDURE) - - elsif Last > Symbol_Vector'Length + Equal_Procedure'Length - and then - Line (Last - Equal_Procedure'Length + 1 .. Last) = - Equal_Procedure - then - Symbol_Table.Increment_Last (Original_Symbols); - Original_Symbols.Table - (Symbol_Table.Last (Original_Symbols)) := - (Name => - new String'(Line (Symbol_Vector'Length + 1 .. - Last - Equal_Procedure'Length)), - Kind => Proc, - Present => True); - - -- Anything else is incorrectly formatted - - else - if not Quiet then - Put_Line ("symbol file """ & Reference & - """ is incorrectly formatted:"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - end if; - - -- Lines with "gsmatch=equal,, - - elsif Last > Gsmatch'Length - and then Line (1 .. Gsmatch'Length) = Gsmatch - then - declare - Start : Positive := Gsmatch'Length + 1; - Finish : Positive := Start; - OK : Boolean := True; - ID : Integer; - - begin - loop - if Line (Finish) not in '0' .. '9' - or else Finish >= Last - 1 - then - OK := False; - exit; - end if; - - exit when Line (Finish + 1) = ','; - - Finish := Finish + 1; - end loop; - - if OK then - ID := Integer'Value (Line (Start .. Finish)); - OK := ID /= 0; - - -- If Soft_Major_ID is True, it means that - -- Library_Version was not specified. - - if Soft_Major_ID then - Major_ID := ID; - - -- If the Major ID in the reference file is different - -- from the Library_Version, then the Minor ID will be 0 - -- because there is no point in taking the Minor ID in - -- the reference file, or incrementing it. So, we set - -- Soft_Minor_ID to False, so that we don't modify - -- the Minor_ID later. - - elsif Major_ID /= ID then - Soft_Minor_ID := False; - end if; - - Start := Finish + 2; - Finish := Start; - - loop - if Line (Finish) not in '0' .. '9' then - OK := False; - exit; - end if; - - exit when Finish = Last; - - Finish := Finish + 1; - end loop; - - -- Only set Minor_ID if Soft_Minor_ID is True (see above) - - if OK and then Soft_Minor_ID then - Minor_ID := Integer'Value (Line (Start .. Finish)); - end if; - end if; - - -- If OK is not True, that means the line is not correctly - -- formatted. - - if not OK then - if not Quiet then - Put_Line ("symbol file """ & Reference & - """ is incorrectly formatted"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - end if; - end; - - -- Anything else is incorrectly formatted - - else - if not Quiet then - Put_Line ("unexpected line in symbol file """ & - Reference & """"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - end if; - end loop; - - Close (File); - end if; - end Initialize; - - ------------- - -- Process -- - ------------- - - procedure Process - (Object_File : String; - Success : out Boolean) - is - begin - -- Open the object file with Byte_IO. Return with Success = False if - -- this fails. - - begin - Open (File, In_File, Object_File); - exception - when others => - Put_Line - ("*** Unable to open object file """ & Object_File & """"); - Success := False; - return; - end; - - -- Assume that the object file has a correct format - - Success := True; - - -- Get the different sections one by one from the object file - - while not End_Of_File (File) loop - - Get (Code); - Get (Number_Of_Characters); - Number_Of_Characters := Number_Of_Characters - 4; - - -- If this is not a Global Symbol Definition section, skip to the - -- next section. - - if Code /= GSD then - - for J in 1 .. Number_Of_Characters loop - Read (File, B); - end loop; - - else - - -- Skip over the next 4 bytes - - Get (Dummy); - Get (Dummy); - Number_Of_Characters := Number_Of_Characters - 4; - - -- Get each subsection in turn - - loop - Get (Code); - Get (Nchars); - Get (Dummy); - Get (Flags); - Number_Of_Characters := Number_Of_Characters - 8; - Nchars := Nchars - 8; - - -- If this is a symbol and the V_DEF flag is set, get the - -- symbol. - - if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then - -- First, reach the symbol length - - for J in 1 .. 25 loop - Read (File, B); - Nchars := Nchars - 1; - Number_Of_Characters := Number_Of_Characters - 1; - end loop; - - Length := Byte'Pos (B); - LSymb := 0; - - -- Get the symbol characters - - for J in 1 .. Nchars loop - Read (File, B); - Number_Of_Characters := Number_Of_Characters - 1; - if Length > 0 then - LSymb := LSymb + 1; - Symbol (LSymb) := B; - Length := Length - 1; - end if; - end loop; - - -- Create the new Symbol - - declare - S_Data : Symbol_Data; - begin - S_Data.Name := new String'(Symbol (1 .. LSymb)); - - -- The symbol kind (Data or Procedure) depends on the - -- V_NORM flag. - - if (Flags and V_NORM_Mask) = 0 then - S_Data.Kind := Data; - - else - S_Data.Kind := Proc; - end if; - - -- Put the new symbol in the table - - Symbol_Table.Increment_Last (Complete_Symbols); - Complete_Symbols.Table - (Symbol_Table.Last (Complete_Symbols)) := S_Data; - end; - - else - -- As it is not a symbol subsection, skip to the next - -- subsection. - - for J in 1 .. Nchars loop - Read (File, B); - Number_Of_Characters := Number_Of_Characters - 1; - end loop; - end if; - - -- Exit the GSD section when number of characters reaches 0 - - exit when Number_Of_Characters = 0; - end loop; - end if; - end loop; - - -- The object file has been processed, close it - - Close (File); - - exception - -- For any exception, output an error message, close the object file - -- and return with Success = False. - - when X : others => - Put_Line ("unexpected exception raised while processing """ - & Object_File & """"); - Put_Line (Exception_Information (X)); - Close (File); - Success := False; - end Process; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize - (Quiet : Boolean; - Success : out Boolean) - is - File : Ada.Text_IO.File_Type; - -- The symbol file - - S_Data : Symbol_Data; - -- A symbol - - Cur : Positive := 1; - -- Most probable index in the Complete_Symbols of the current symbol - -- in Original_Symbol. - - Found : Boolean; - - begin - -- Nothing to be done if Initialize has never been called - - if Symbol_File_Name = null then - Success := False; - - else - - -- First find if the symbols in the reference symbol file are also - -- in the object files. Note that this is not done if the policy is - -- Autonomous, because no reference symbol file has been read. - - -- Expect the first symbol in the symbol file to also be the first - -- in Complete_Symbols. - - Cur := 1; - - for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop - S_Data := Original_Symbols.Table (Index_1); - Found := False; - - First_Object_Loop : - for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop - if Equal (S_Data, Complete_Symbols.Table (Index_2)) then - Cur := Index_2 + 1; - Complete_Symbols.Table (Index_2).Present := False; - Found := True; - exit First_Object_Loop; - end if; - end loop First_Object_Loop; - - -- If the symbol could not be found between Cur and Last, try - -- before Cur. - - if not Found then - Second_Object_Loop : - for Index_2 in 1 .. Cur - 1 loop - if Equal (S_Data, Complete_Symbols.Table (Index_2)) then - Cur := Index_2 + 1; - Complete_Symbols.Table (Index_2).Present := False; - Found := True; - exit Second_Object_Loop; - end if; - end loop Second_Object_Loop; - end if; - - -- If the symbol is not found, mark it as such in the table - - if not Found then - if (not Quiet) or else Sym_Policy = Controlled then - Put_Line ("symbol """ & S_Data.Name.all & - """ is no longer present in the object files"); - end if; - - if Sym_Policy = Controlled then - Success := False; - return; - - elsif Soft_Minor_ID then - Minor_ID := Minor_ID + 1; - Soft_Minor_ID := False; - end if; - - Original_Symbols.Table (Index_1).Present := False; - Free (Original_Symbols.Table (Index_1).Name); - - if Soft_Minor_ID then - Minor_ID := Minor_ID + 1; - Soft_Minor_ID := False; - end if; - end if; - end loop; - - -- Append additional symbols, if any, to the Original_Symbols table - - for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop - S_Data := Complete_Symbols.Table (Index); - - if S_Data.Present then - - if Sym_Policy = Controlled then - Put_Line ("symbol """ & S_Data.Name.all & - """ is not in the reference symbol file"); - Success := False; - return; - - elsif Soft_Minor_ID then - Minor_ID := Minor_ID + 1; - Soft_Minor_ID := False; - end if; - - Symbol_Table.Increment_Last (Original_Symbols); - Original_Symbols.Table (Symbol_Table.Last (Original_Symbols)) := - S_Data; - Complete_Symbols.Table (Index).Present := False; - end if; - end loop; - - -- Create the symbol file - - Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all); - - Put (File, Case_Sensitive); - Put_Line (File, "yes"); - - -- Put a line in the symbol file for each symbol in the symbol table - - for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop - if Original_Symbols.Table (Index).Present then - Put (File, Symbol_Vector); - Put (File, Original_Symbols.Table (Index).Name.all); - - if Original_Symbols.Table (Index).Kind = Data then - Put_Line (File, Equal_Data); - - else - Put_Line (File, Equal_Procedure); - end if; - - Free (Original_Symbols.Table (Index).Name); - end if; - end loop; - - Put (File, Case_Sensitive); - Put_Line (File, "NO"); - - -- Put the version IDs - - Put (File, Gsmatch); - Put (File, Image (Major_ID)); - Put (File, ','); - Put_Line (File, Image (Minor_ID)); - - -- And we are done - - Close (File); - - -- Reset both tables - - Symbol_Table.Set_Last (Original_Symbols, 0); - Symbol_Table.Set_Last (Complete_Symbols, 0); - - -- Clear the symbol file name - - Free (Symbol_File_Name); - - Success := True; - end if; - - exception - when X : others => - Put_Line ("unexpected exception raised while finalizing """ - & Symbol_File_Name.all & """"); - Put_Line (Exception_Information (X)); - Success := False; - end Finalize; - -end Symbols; diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index ca621b033b6..df0211d226b 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -4246,6 +4246,8 @@ package VMS_Data is -- UPPER_CASE S_Pretty_Comments : aliased constant S := "/COMMENTS_LAYOUT=" & + "UNTOUCHED " & + "-c0 " & "DEFAULT " & "-c1 " & "STANDARD_INDENT " & @@ -4256,17 +4258,20 @@ package VMS_Data is "-c4"; -- /COMMENTS_LAYOUT[=layout-option, layout-option, ...] -- - -- Set the comment layout. By default, comments use the GNAT style comment - -- line indentation. - -- layout-option may be one of the following: + -- Set the comment layout. By default, comments use the GNAT style + -- comment line indentation. -- + -- layout-option is be one of the following: + -- + -- UNTOUCHED           All the comments remain unchanged -- DEFAULT (D) GNAT style comment line indentation -- STANDARD_INDENT Standard comment line indentation -- GNAT_BEGINNING GNAT style comment beginning -- REFORMAT Reformat comment blocks -- -- All combinations of layout options are allowed, except for DEFAULT - -- and STANDARD_INDENT which are mutually exclusive. + -- and STANDARD_INDENT which are mutually exclusive, and also if + -- UNTOUCHED is specified, this must be the only option. -- -- The difference between "GNAT style comment line indentation" and -- "standard comment line indentation" is the following: for standard @@ -4492,6 +4497,13 @@ package VMS_Data is -- -- MIXED_CASE Names are in mixed case. + S_Pretty_No_Backup : aliased constant S := "/NO_BACKUP " & + "-rnb"; + -- /REPLACE_NO_BACKUP + -- + -- Replace the argument source with the pretty-printed source without + -- creating any backup copy of the argument source. + S_Pretty_No_Labels : aliased constant S := "/NO_MISSED_LABELS " & "-e"; -- /NO_MISSED_LABELS @@ -4533,7 +4545,8 @@ package VMS_Data is "LOWER_CASE " & "-pL " & "UPPER_CASE " & - -- /PRAGMA_CASING[=pragma-option] + "-pU"; + -- /PRAGMA_CASING[=pragma-option] -- -- Set the case of pragma identifiers. The default is Mixed case. -- pragma-option may be one of the following: @@ -4541,9 +4554,9 @@ package VMS_Data is -- MIXED_CASE (D) -- LOWER_CASE -- UPPER_CASE - "-pU"; - S_Pretty_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; + + S_Pretty_Project : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; -- /PROJECT_FILE=filename -- -- Specifies the main project file to be used. The project files rooted @@ -4621,6 +4634,7 @@ package VMS_Data is S_Pretty_Maxind 'Access, S_Pretty_Mess 'Access, S_Pretty_Names 'Access, + S_Pretty_No_Backup 'Access, S_Pretty_No_Labels 'Access, S_Pretty_Notabs 'Access, S_Pretty_Output 'Access,