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. - - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - Tmp_Handler.all; - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - - elsif User_Entry (Interrupt).T /= Null_Task then - Tmp_ID := User_Entry (Interrupt).T; - Tmp_Entry_Index := User_Entry (Interrupt).E; - - -- RTS calls should not be made with self being locked. - - if Single_Lock then - POP.Unlock_RTS; - end if; - - POP.Unlock (Self_ID); - - System.Tasking.Rendezvous.Call_Simple - (Tmp_ID, Tmp_Entry_Index, System.Null_Address); - - POP.Write_Lock (Self_ID); - - if Single_Lock then - POP.Lock_RTS; - end if; + null; 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; + -- 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. - IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt)); + -- If there is no calls to make we need to regenerate the + -- Interrupt in order not to lose it. + + if User_Handler (Interrupt).H /= null then + Tmp_Handler := User_Handler (Interrupt).H; + + -- RTS calls should not be made with self being locked. + + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + Tmp_Handler.all; + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + + elsif User_Entry (Interrupt).T /= Null_Task then + Tmp_ID := User_Entry (Interrupt).T; + Tmp_Entry_Index := User_Entry (Interrupt).E; + + -- RTS calls should not be made with self being locked. + + if Single_Lock then + POP.Unlock_RTS; + end if; + + POP.Unlock (Self_ID); + + System.Tasking.Rendezvous.Call_Simple + (Tmp_ID, Tmp_Entry_Index, System.Null_Address); + + 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.adb b/gcc/ada/symbols-vms-alpha.adb similarity index 100% rename from gcc/ada/symbols-vms.adb rename to gcc/ada/symbols-vms-alpha.adb 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,