diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 23 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 63 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-linux.adb | 200 | ||||
| -rw-r--r-- | gcc/ada/s-taspri-posix-noaltstack.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/s-taspri-posix.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/s-trasym.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 55 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/sem_elab.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_elab.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 64 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/sinput.ads | 2 |
13 files changed, 253 insertions, 213 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 15ae2ab..dfe1102 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,28 @@ 2017-05-02 Tristan Gingold <gingold@adacore.com> + * s-trasym.ads: Add comment. + +2017-05-02 Bob Duff <duff@adacore.com> + + * sem_elab.adb, sem_elab.ads: Minor comment fixes. + * sem_ch4.adb: Minor reformatting. + * s-taprop-linux.adb, s-taspri-posix.ads: Code refactoring. + * s-taspri-posix-noaltstack.ads: Minor refactoring. + * sinput.ads: Minor typo fix. + +2017-05-02 Ed Schonberg <schonberg@adacore.com> + + * exp_ch9.adb (Discriminated_Size): Moved to sem_util. + * sem_util.ads, sem_util.adb (Discriminated_Size): Predicate moved + here from exp_ch9, to recognize objects whose creation requires + dynamic allocation, so that the proper warning can be emitted + when restriction No_Implicit_Heap_Allocation is in effect. + * sem_ch3.adb (Analyze_Object_Declaration): Use Discriminated_Size + to emit proper warning when an object that requires dynamic + allocation is declared. + +2017-05-02 Tristan Gingold <gingold@adacore.com> + * s-trasym.ads, s-trasym.adb (Enable_Cache): New. 2017-05-02 Ed Schonberg <schonberg@adacore.com> diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 28244c3..ecca4c3 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -8725,12 +8725,6 @@ package body Exp_Ch9 is -- to the internal body, for possible inlining later on. The source -- operation is invisible to the back-end and is never actually called. - function Discriminated_Size (Comp : Entity_Id) return Boolean; - -- If a component size is not static then a warning will be emitted - -- in Ravenscar or other restricted contexts. When a component is non- - -- static because of a discriminant constraint we can specialize the - -- warning by mentioning discriminants explicitly. - procedure Expand_Entry_Declaration (Decl : Node_Id); -- Create the entry barrier and the procedure body for entry declaration -- Decl. All generated subprograms are added to Entry_Bodies_Array. @@ -8758,63 +8752,6 @@ package body Exp_Ch9 is end if; end Check_Inlining; - ------------------------ - -- Discriminated_Size -- - ------------------------ - - function Discriminated_Size (Comp : Entity_Id) return Boolean is - Typ : constant Entity_Id := Etype (Comp); - Index : Node_Id; - - function Non_Static_Bound (Bound : Node_Id) return Boolean; - -- Check whether the bound of an index is non-static and does denote - -- a discriminant, in which case any protected object of the type - -- will have a non-static size. - - ---------------------- - -- Non_Static_Bound -- - ---------------------- - - function Non_Static_Bound (Bound : Node_Id) return Boolean is - begin - if Is_OK_Static_Expression (Bound) then - return False; - - elsif Is_Entity_Name (Bound) - and then Present (Discriminal_Link (Entity (Bound))) - then - return False; - - else - return True; - end if; - end Non_Static_Bound; - - -- Start of processing for Discriminated_Size - - begin - if not Is_Array_Type (Typ) then - return False; - end if; - - if Ekind (Typ) = E_Array_Subtype then - Index := First_Index (Typ); - while Present (Index) loop - if Non_Static_Bound (Low_Bound (Index)) - or else Non_Static_Bound (High_Bound (Index)) - then - return False; - end if; - - Next_Index (Index); - end loop; - - return True; - end if; - - return False; - end Discriminated_Size; - --------------------------- -- Static_Component_Size -- --------------------------- diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index 745f132..bc49f68 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -174,6 +174,14 @@ package body System.Task_Primitives.Operations is pragma Import (C, GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup"); + type RTS_Lock_Ptr is not null access all RTS_Lock; + + function Init_Mutex + (L : RTS_Lock_Ptr; Prio : Any_Priority) + return Interfaces.C.int; + -- Initialize the mutex L. If the locking policy is Ceiling_Locking, then + -- set the ceiling to Prio. + ------------------- -- Abort_Handler -- ------------------- @@ -260,6 +268,54 @@ package body System.Task_Primitives.Operations is function Self return Task_Id renames Specific.Self; + ---------------- + -- Init_Mutex -- + ---------------- + + function Init_Mutex + (L : RTS_Lock_Ptr; Prio : Any_Priority) + return Interfaces.C.int + is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + begin + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + return ENOMEM; + end if; + + if Locking_Policy = 'C' then + if Superuser then + Result := pthread_mutexattr_setprotocol + (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Mutex_Attr'Access, Interfaces.C.int (Prio)); + pragma Assert (Result = 0); + end if; + + elsif Locking_Policy = 'I' then + Result := pthread_mutexattr_setprotocol + (Mutex_Attr'Access, PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + return ENOMEM; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + return 0; + end Init_Mutex; + --------------------- -- Initialize_Lock -- --------------------- @@ -301,46 +357,9 @@ package body System.Task_Primitives.Operations is end; else - declare - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - if Superuser then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_PROTECT); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Attributes'Access, Interfaces.C.int (Prio)); - pragma Assert (Result = 0); - end if; - - elsif Locking_Policy = 'I' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_INHERIT); - pragma Assert (Result = 0); - end if; - - Result := pthread_mutex_init (L.WO'Access, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error with "Failed to allocate a lock"; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end; + if Init_Mutex (L.WO'Access, Prio) = ENOMEM then + raise Storage_Error with "Failed to allocate a lock"; + end if; end if; end Initialize_Lock; @@ -348,45 +367,10 @@ package body System.Task_Primitives.Operations is (L : not null access RTS_Lock; Level : Lock_Level) is pragma Unreferenced (Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - if Superuser then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_PROTECT); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); - pragma Assert (Result = 0); - end if; - - elsif Locking_Policy = 'I' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_INHERIT); - pragma Assert (Result = 0); + if Init_Mutex (L.all'Access, Any_Priority'Last) = ENOMEM then + raise Storage_Error with "Failed to allocate a lock"; end if; - - Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); end Initialize_Lock; ------------------- @@ -919,7 +903,6 @@ package body System.Task_Primitives.Operations is -------------------- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is - Mutex_Attr : aliased pthread_mutexattr_t; Result : Interfaces.C.int; Cond_Attr : aliased pthread_condattr_t; @@ -933,47 +916,12 @@ package body System.Task_Primitives.Operations is Self_ID.Common.LL.Thread := Null_Thread_Id; if not Single_Lock then - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - if Locking_Policy = 'C' then - if Superuser then - Result := - pthread_mutexattr_setprotocol - (Mutex_Attr'Access, - PTHREAD_PRIO_PROTECT); - pragma Assert (Result = 0); - - Result := - pthread_mutexattr_setprioceiling - (Mutex_Attr'Access, - Interfaces.C.int (System.Any_Priority'Last)); - pragma Assert (Result = 0); - end if; - - elsif Locking_Policy = 'I' then - Result := - pthread_mutexattr_setprotocol - (Mutex_Attr'Access, - PTHREAD_PRIO_INHERIT); - pragma Assert (Result = 0); - end if; - - Result := - pthread_mutex_init - (Self_ID.Common.LL.L'Access, - Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result /= 0 then + if Init_Mutex + (Self_ID.Common.LL.L'Access, System.Any_Priority'Last) /= 0 + then Succeeded := False; return; end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); end if; Result := pthread_condattr_init (Cond_Attr'Access); @@ -1015,7 +963,7 @@ package body System.Task_Primitives.Operations is Priority : System.Any_Priority; Succeeded : out Boolean) is - Attributes : aliased pthread_attr_t; + Thread_Attr : aliased pthread_attr_t; Adjusted_Stack_Size : Interfaces.C.size_t; Result : Interfaces.C.int; @@ -1039,7 +987,7 @@ package body System.Task_Primitives.Operations is Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); - Result := pthread_attr_init (Attributes'Access); + Result := pthread_attr_init (Thread_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); if Result /= 0 then @@ -1048,12 +996,12 @@ package body System.Task_Primitives.Operations is end if; Result := - pthread_attr_setstacksize (Attributes'Access, Adjusted_Stack_Size); + pthread_attr_setstacksize (Thread_Attr'Access, Adjusted_Stack_Size); pragma Assert (Result = 0); Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); + (Thread_Attr'Access, PTHREAD_CREATE_DETACHED); pragma Assert (Result = 0); -- Set the required attributes for the creation of the thread @@ -1083,7 +1031,7 @@ package body System.Task_Primitives.Operations is System.OS_Interface.CPU_SET (int (T.Common.Base_CPU), Size, CPU_Set); Result := - pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set); + pthread_attr_setaffinity_np (Thread_Attr'Access, Size, CPU_Set); pragma Assert (Result = 0); CPU_FREE (CPU_Set); @@ -1094,7 +1042,7 @@ package body System.Task_Primitives.Operations is elsif T.Common.Task_Info /= null then Result := pthread_attr_setaffinity_np - (Attributes'Access, + (Thread_Attr'Access, CPU_SETSIZE / 8, T.Common.Task_Info.CPU_Affinity'Access); pragma Assert (Result = 0); @@ -1131,7 +1079,7 @@ package body System.Task_Primitives.Operations is end loop; Result := - pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set); + pthread_attr_setaffinity_np (Thread_Attr'Access, Size, CPU_Set); pragma Assert (Result = 0); CPU_FREE (CPU_Set); @@ -1151,7 +1099,7 @@ package body System.Task_Primitives.Operations is Result := pthread_create (T.Common.LL.Thread'Unrestricted_Access, - Attributes'Access, + Thread_Attr'Access, Thread_Body_Access (Wrapper), To_Address (T)); @@ -1160,14 +1108,14 @@ package body System.Task_Primitives.Operations is if Result /= 0 then Succeeded := False; - Result := pthread_attr_destroy (Attributes'Access); + Result := pthread_attr_destroy (Thread_Attr'Access); pragma Assert (Result = 0); return; end if; Succeeded := True; - Result := pthread_attr_destroy (Attributes'Access); + Result := pthread_attr_destroy (Thread_Attr'Access); pragma Assert (Result = 0); Set_Priority (T, Priority); diff --git a/gcc/ada/s-taspri-posix-noaltstack.ads b/gcc/ada/s-taspri-posix-noaltstack.ads index aadcfbf..92c22b6 100644 --- a/gcc/ada/s-taspri-posix-noaltstack.ads +++ b/gcc/ada/s-taspri-posix-noaltstack.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2014, AdaCore -- +-- Copyright (C) 1995-2017, AdaCore -- -- -- -- 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- -- @@ -73,13 +73,13 @@ package System.Task_Primitives is private + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + type Lock is record - WO : aliased System.OS_Interface.pthread_mutex_t; + WO : aliased RTS_Lock; RW : aliased System.OS_Interface.pthread_rwlock_t; end record; - type RTS_Lock is new System.OS_Interface.pthread_mutex_t; - type Suspension_Object is record State : Boolean; pragma Atomic (State); @@ -90,7 +90,7 @@ private Waiting : Boolean; -- Flag showing if there is a task already suspended on this object - L : aliased System.OS_Interface.pthread_mutex_t; + L : aliased RTS_Lock; -- Protection for ensuring mutual exclusion on the Suspension_Object CV : aliased System.OS_Interface.pthread_cond_t; diff --git a/gcc/ada/s-taspri-posix.ads b/gcc/ada/s-taspri-posix.ads index a492a17..8eb481f 100644 --- a/gcc/ada/s-taspri-posix.ads +++ b/gcc/ada/s-taspri-posix.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2014, AdaCore -- +-- Copyright (C) 1995-2017, AdaCore -- -- -- -- 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- -- @@ -72,13 +72,13 @@ package System.Task_Primitives is private + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + type Lock is record RW : aliased System.OS_Interface.pthread_rwlock_t; - WO : aliased System.OS_Interface.pthread_mutex_t; + WO : aliased RTS_Lock; end record; - type RTS_Lock is new System.OS_Interface.pthread_mutex_t; - type Suspension_Object is record State : Boolean; pragma Atomic (State); @@ -89,7 +89,7 @@ private Waiting : Boolean; -- Flag showing if there is a task already suspended on this object - L : aliased System.OS_Interface.pthread_mutex_t; + L : aliased RTS_Lock; -- Protection for ensuring mutual exclusion on the Suspension_Object CV : aliased System.OS_Interface.pthread_cond_t; diff --git a/gcc/ada/s-trasym.ads b/gcc/ada/s-trasym.ads index 7165437..4d3c922 100644 --- a/gcc/ada/s-trasym.ads +++ b/gcc/ada/s-trasym.ads @@ -86,6 +86,9 @@ package System.Traceback.Symbolic is -- Read symbolic information from binary files and cache them in memory. -- This will speed up the above functions but will require more memory. -- If Include_Modules is true, shared modules (or DLL) will also be cached. - -- This procedure may do nothing if not supported. + -- This procedure may do nothing if not supported. The profile of this + -- subprogram may change in the future (new parameters can be added with + -- default value), but backward compatibility for direct calls is + -- supported. end System.Traceback.Symbolic; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 4f7691b..8f3cf1e 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3133,6 +3133,9 @@ package body Sem_Ch3 is when N_Derived_Type_Definition => Derived_Type_Declaration (T, N, T /= Def_Id); + if Ekind (T) /= E_Void and then Has_Predicates (T) then -- ???? + Set_Has_Predicates (Def_Id); + end if; when N_Enumeration_Type_Definition => Enumeration_Type_Declaration (T, Def); @@ -3588,6 +3591,11 @@ package body Sem_Ch3 is Prev_Entity : Entity_Id := Empty; + procedure Check_Dynamic_Object (Typ : Entity_Id); + -- A library-level object with non-static discriminant constraints may + -- require dynamic allocation. The declaration is illegal if the + -- profile includes the restriction No_Implicit_Heap_Allocations. + procedure Check_For_Null_Excluding_Components (Obj_Typ : Entity_Id; Obj_Decl : Node_Id); @@ -3614,6 +3622,45 @@ package body Sem_Ch3 is -- Any other relevant delayed aspects on object declarations ??? + procedure Check_Dynamic_Object (Typ : Entity_Id) is + Comp : Entity_Id; + Obj_Type : Entity_Id; + + begin + Obj_Type := Typ; + if Is_Private_Type (Obj_Type) + and then Present (Full_View (Obj_Type)) + then + Obj_Type := Full_View (Obj_Type); + end if; + + if Known_Static_Esize (Obj_Type) then + return; + end if; + + if Restriction_Active (No_Implicit_Heap_Allocations) + and then Expander_Active + and then Has_Discriminants (Obj_Type) + then + Comp := First_Component (Obj_Type); + while Present (Comp) loop + if Known_Static_Esize (Etype (Comp)) then + null; + + elsif not Discriminated_Size (Comp) + and then Comes_From_Source (Comp) + then + Error_Msg_NE ("component& of non-static size will violate " + & "restriction No_Implicit_Heap_Allocation?", N, Comp); + + elsif Is_Record_Type (Etype (Comp)) then + Check_Dynamic_Object (Etype (Comp)); + end if; + Next_Component (Comp); + end loop; + end if; + end Check_Dynamic_Object; + ----------------------------------------- -- Check_For_Null_Excluding_Components -- ----------------------------------------- @@ -4068,6 +4115,10 @@ package body Sem_Ch3 is Object_Definition (N)); end if; + if Is_Library_Level_Entity (Id) then + Check_Dynamic_Object (T); + end if; + -- There are no aliased objects in SPARK if Aliased_Present (N) then @@ -15458,6 +15509,10 @@ package body Sem_Ch3 is and then Has_Non_Trivial_Precondition (Parent_Subp) and then Present (Interfaces (Derived_Type)) then + + -- Add useful attributes of subprogram before the freeze point, + -- in case freezing is delayed or there are previous errors. + Set_Is_Dispatching_Operation (New_Subp); declare diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 9a22b8e..8a94f3f 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4930,7 +4930,8 @@ package body Sem_Ch4 is if Comp = First_Private_Entity (Type_To_Use) then if Etype (Sel) /= Any_Type then - -- We have a candiate. + -- We have a candiate + exit; else @@ -4993,8 +4994,8 @@ package body Sem_Ch4 is then if Present (Hidden_Comp) then Error_Msg_NE - ("invalid reference to private component of object " - & "of type &", N, Type_To_Use); + ("invalid reference to private component of object of type " + & "&", N, Type_To_Use); else Error_Msg_NE @@ -6476,13 +6477,14 @@ package body Sem_Ch4 is -- Either the types are compatible, or one operand is universal -- (numeric or null). - or else ((In_Instance or else In_Inlined_Body) - and then - (First_Subtype (T1) = First_Subtype (Etype (R)) - or else Nkind (R) = N_Null - or else - (Is_Numeric_Type (T1) - and then Is_Universal_Numeric_Type (Etype (R))))) + or else + ((In_Instance or else In_Inlined_Body) + and then + (First_Subtype (T1) = First_Subtype (Etype (R)) + or else Nkind (R) = N_Null + or else + (Is_Numeric_Type (T1) + and then Is_Universal_Numeric_Type (Etype (R))))) -- In Ada 2005, the equality on anonymous access types is declared -- in Standard, and is always visible. diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 0588c61..25c3d44 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -1073,7 +1073,7 @@ package body Sem_Elab is -- Indirect call case, info message only in static elaboration -- case, because the attribute reference itself cannot raise an - -- exception. Note that SPARK does not permit indirect calls. + -- exception. Note that SPARK does not permit indirect calls. elsif Access_Case then Elab_Warning ("", "info: access to & during elaboration?$?", Ent); diff --git a/gcc/ada/sem_elab.ads b/gcc/ada/sem_elab.ads index 3db19da..c8aec66 100644 --- a/gcc/ada/sem_elab.ads +++ b/gcc/ada/sem_elab.ads @@ -174,7 +174,7 @@ package Sem_Elab is -- not be generated (see detailed description in body). procedure Check_Task_Activation (N : Node_Id); - -- Tt the point at which tasks are activated in a package body, check + -- At the point at which tasks are activated in a package body, check -- that the bodies of the tasks are elaborated. end Sem_Elab; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e8fc728..52b7ccc 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6312,6 +6312,70 @@ package body Sem_Util is return Make_Level_Literal (Type_Access_Level (Etype (Expr))); end Dynamic_Accessibility_Level; + ------------------------ + -- Discriminated_Size -- + ------------------------ + + function Discriminated_Size (Comp : Entity_Id) return Boolean is + Typ : constant Entity_Id := Etype (Comp); + Index : Node_Id; + + function Non_Static_Bound (Bound : Node_Id) return Boolean; + -- Check whether the bound of an index is non-static and does denote + -- a discriminant, in which case any object of the type (protected + -- or otherwise) will have a non-static size. + + ---------------------- + -- Non_Static_Bound -- + ---------------------- + + function Non_Static_Bound (Bound : Node_Id) return Boolean is + begin + if Is_OK_Static_Expression (Bound) then + return False; + + -- If the bound is given by a discriminant it is non-static + -- (A static constraint replaces the reference with the value). + -- In an protected object the discriminant has been replaced by + -- the corresponding discriminal within the protected operation. + + elsif Is_Entity_Name (Bound) + and then + (Ekind (Entity (Bound)) = E_Discriminant + or else Present (Discriminal_Link (Entity (Bound)))) + then + return False; + + else + return True; + end if; + end Non_Static_Bound; + + -- Start of processing for Discriminated_Size + + begin + if not Is_Array_Type (Typ) then + return False; + end if; + + if Ekind (Typ) = E_Array_Subtype then + Index := First_Index (Typ); + while Present (Index) loop + if Non_Static_Bound (Low_Bound (Index)) + or else Non_Static_Bound (High_Bound (Index)) + then + return False; + end if; + + Next_Index (Index); + end loop; + + return True; + end if; + + return False; + end Discriminated_Size; + ----------------------------------- -- Effective_Extra_Accessibility -- ----------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 9df6422..74e1841 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -601,6 +601,14 @@ package Sem_Util is -- accessibility levels are tracked at runtime (access parameters and Ada -- 2012 stand-alone objects). + function Discriminated_Size (Comp : Entity_Id) return Boolean; + -- If a component size is not static then a warning will be emitted + -- in Ravenscar or other restricted contexts. When a component is non- + -- static because of a discriminant constraint we can specialize the + -- warning by mentioning discriminants explicitly. This was created for + -- private components of protected objects, but is generally useful when + -- retriction (No_Implicit_Heap_Allocation) is active. + function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id; -- Same as Einfo.Extra_Accessibility except thtat object renames -- are looked through. diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index 6b5b412..762335f 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -494,7 +494,7 @@ package Sinput is -- NEL code. Now such programs can of course be compiled in UTF-8 mode, -- but in practice they also compile fine in standard 8-bit mode without -- specifying a character encoding. Since this is common practice, it would - -- be a signficant upwards incompatibility to recognize NEL in 8-bit mode. + -- be a significant upwards incompatibility to recognize NEL in 8-bit mode. ----------------- -- Subprograms -- |