+2016-06-22 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb, sem_type.adb, sem.adb, freeze.adb, sem_util.adb,
+ s-htable.adb, exp_ch11.adb, s-secsta.adb, restrict.adb, exp_disp.adb,
+ sem_ch8.adb, s-tpobop.adb, exp_aggr.ads, sem_ch13.adb: Minor
+ reformatting.
+
+2016-06-22 Yannick Moy <moy@adacore.com>
+
+ * lib-xref-spark_specific.adb (Collect_SPARK_Xrefs): Inverse order of
+ treatments so that files without compilation unit are simply skipped
+ before more elaborate treatments.
+
+2016-06-22 Bob Duff <duff@adacore.com>
+
+ * s-memory.ads: Minor typo fixes in comments.
+ * s-memory.adb: Code cleanup.
+
2016-05-22 Olivier Hainque <hainque@adacore.com>
* vxworks-crtbe-link.spec: Removed, no longer used.
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
-- are compile-time known constants, rewrite N as a purely positional
-- aggregate, to be use to initialize variables and components of the type
-- without generating elaboration code.
+
end Exp_Aggr;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
-- expansion as described above.
procedure Expand_Local_Exception_Handlers is
-
procedure Add_Exception_Label (H : Node_Id);
-- H is an exception handler. First check for an Exception_Label
-- already allocated for H. If none, allocate one, set the field in
if Present (Thunk_Id) then
Append_To (Result, Thunk_Code);
- Prim_Table (UI_To_Int (DT_Position (Prim)))
- := Thunk_Id;
+ Prim_Table (UI_To_Int (DT_Position (Prim))) :=
+ Thunk_Id;
end if;
end if;
end if;
-- Comp_ADC_Present is set True if the component has a Scalar_Storage_Order
-- attribute definition clause.
+ procedure Check_Debug_Info_Needed (T : Entity_Id);
+ -- As each entity is frozen, this routine is called to deal with the
+ -- setting of Debug_Info_Needed for the entity. This flag is set if
+ -- the entity comes from source, or if we are in Debug_Generated_Code
+ -- mode or if the -gnatdV debug flag is set. However, it never sets
+ -- the flag if Debug_Info_Off is set. This procedure also ensures that
+ -- subsidiary entities have the flag set as required.
+
procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id);
-- When an expression function is frozen by a use of it, the expression
-- itself is frozen. Check that the expression does not include references
-- the default component alignment from the scope stack values if the
-- alignment is otherwise not specified.
- procedure Check_Debug_Info_Needed (T : Entity_Id);
- -- As each entity is frozen, this routine is called to deal with the
- -- setting of Debug_Info_Needed for the entity. This flag is set if
- -- the entity comes from source, or if we are in Debug_Generated_Code
- -- mode or if the -gnatdV debug flag is set. However, it never sets
- -- the flag if Debug_Info_Off is set. This procedure also ensures that
- -- subsidiary entities have the flag set as required.
-
procedure Set_SSO_From_Default (T : Entity_Id);
-- T is a record or array type that is being frozen. If it is a base type,
-- and if SSO_Set_Low/High_By_Default is set, then Reverse_Storage order
-- Bit packing is never needed for 8, 16, 32, 64
if Addressable (Csiz) then
+
-- If the Esize of the component is known and equal to
-- the component size then even packing is not needed.
Sdep := 1;
while Sdep <= Num_Sdep loop
+ -- Skip dependencies with no entity node, e.g. configuration files
+ -- with pragmas (.adc) or target description (.atp), since they
+ -- present no interest for SPARK cross references.
+
+ if No (Cunit_Entity (Sdep_Table (Sdep))) then
+ Sdep_Next := Sdep + 1;
+
-- For library-level instantiation of a generic, two consecutive
-- units refer to the same compilation unit node and entity (one to
-- body, one to spec). In that case, treat them as a single unit for
-- the sake of SPARK cross references by passing to Add_SPARK_File.
- if Sdep < Num_Sdep
- and then Cunit_Entity (Sdep_Table (Sdep)) =
- Cunit_Entity (Sdep_Table (Sdep + 1))
- then
- declare
- Cunit1 : Node_Id renames Cunit (Sdep_Table (Sdep));
- Cunit2 : Node_Id renames Cunit (Sdep_Table (Sdep + 1));
-
- begin
- -- Both Cunit point to compilation unit nodes
+ else
+ if Sdep < Num_Sdep
+ and then Cunit_Entity (Sdep_Table (Sdep)) =
+ Cunit_Entity (Sdep_Table (Sdep + 1))
+ then
+ declare
+ Cunit1 : Node_Id renames Cunit (Sdep_Table (Sdep));
+ Cunit2 : Node_Id renames Cunit (Sdep_Table (Sdep + 1));
- pragma Assert
- (Nkind (Cunit1) = N_Compilation_Unit
- and then Nkind (Cunit2) = N_Compilation_Unit);
+ begin
+ -- Both Cunits point to compilation unit nodes
- -- Do not depend on the sorting order, which is based on
- -- Unit_Name and for library-level instances of nested
- -- generic-packages they are equal.
+ pragma Assert
+ (Nkind (Cunit1) = N_Compilation_Unit
+ and then Nkind (Cunit2) = N_Compilation_Unit);
- -- If declaration comes before the body
+ -- Do not depend on the sorting order, which is based on
+ -- Unit_Name, and for library-level instances of nested
+ -- generic packages they are equal.
- if Nkind (Unit (Cunit1)) = N_Package_Declaration
- and then Nkind (Unit (Cunit2)) = N_Package_Body
- then
- Uspec := Sdep_Table (Sdep);
- Ubody := Sdep_Table (Sdep + 1);
+ -- If declaration comes before the body
- Sdep_File := Sdep + 1;
+ if Nkind (Unit (Cunit1)) = N_Package_Declaration
+ and then Nkind (Unit (Cunit2)) = N_Package_Body
+ then
+ Uspec := Sdep_Table (Sdep);
+ Ubody := Sdep_Table (Sdep + 1);
- -- If body comes before declaration
+ Sdep_File := Sdep + 1;
- elsif Nkind (Unit (Cunit1)) = N_Package_Body
- and then Nkind (Unit (Cunit2)) = N_Package_Declaration
- then
- Uspec := Sdep_Table (Sdep + 1);
- Ubody := Sdep_Table (Sdep);
+ -- If body comes before declaration
- Sdep_File := Sdep;
+ elsif Nkind (Unit (Cunit1)) = N_Package_Body
+ and then Nkind (Unit (Cunit2)) = N_Package_Declaration
+ then
+ Uspec := Sdep_Table (Sdep + 1);
+ Ubody := Sdep_Table (Sdep);
- -- Otherwise it is an error
+ Sdep_File := Sdep;
- else
- raise Program_Error;
- end if;
+ -- Otherwise it is an error
- Sdep_Next := Sdep + 2;
- end;
+ else
+ raise Program_Error;
+ end if;
- -- ??? otherwise?
+ Sdep_Next := Sdep + 2;
+ end;
- else
- Uspec := Sdep_Table (Sdep);
- Ubody := No_Unit;
+ -- ??? otherwise?
- Sdep_File := Sdep;
- Sdep_Next := Sdep + 1;
- end if;
+ else
+ Uspec := Sdep_Table (Sdep);
+ Ubody := No_Unit;
- -- Skip dependencies with no entity node, e.g. configuration files
- -- with pragmas (.adc) or target description (.atp), since they
- -- present no interest for SPARK cross references.
+ Sdep_File := Sdep;
+ Sdep_Next := Sdep + 1;
+ end if;
- if Present (Cunit_Entity (Uspec)) then
Add_SPARK_File
(Uspec => Uspec,
Ubody => Ubody,
-- Note: body of this function must be coordinated with list of renaming
-- declarations in System.Rident.
- function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
- is
+ function Process_Restriction_Synonyms (N : Node_Id) return Name_Id is
Old_Name : constant Name_Id := Chars (N);
New_Name : Name_Id;
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2015, AdaCore --
+-- Copyright (C) 1995-2016, 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- --
-- Get --
---------
- function Get (K : Key) return Element is
+ function Get (K : Key) return Element is
Tmp : constant Elmt_Ptr := Tab.Get (K);
begin
if Tmp = null then
function Alloc (Size : size_t) return System.Address is
Result : System.Address;
-
begin
+ -- A previous version moved the check for size_t'Last below, into the
+ -- "if Result = System.Null_Address...". So malloc(size_t'Last) should
+ -- return Null_Address, and then we can check for that special value.
+ -- However, that doesn't work on VxWorks, because malloc(size_t'Last)
+ -- prints an unwanted warning message before returning Null_Address.
+
+ if Size = size_t'Last then
+ raise Storage_Error with "object too large";
+ end if;
+
if Parameters.No_Abort then
Result := c_malloc (System.CRTL.size_t (Size));
else
return Alloc (1);
end if;
- if Size = size_t'Last then
- raise Storage_Error with "object too large";
- end if;
-
raise Storage_Error with "heap exhausted";
end if;
is
Result : System.Address;
begin
+ if Size = size_t'Last then
+ raise Storage_Error with "object too large";
+ end if;
+
if Parameters.No_Abort then
Result := c_realloc (Ptr, System.CRTL.size_t (Size));
else
end if;
if Result = System.Null_Address then
- if Size = size_t'Last then
- raise Storage_Error with "object too large";
- end if;
-
raise Storage_Error with "heap exhausted";
end if;
-- memory. The implementation of this routine is guaranteed to be
-- task safe, and also aborts are deferred if necessary.
--
- -- If size_t is set to size_t'Last on entry, then a Storage_Error
+ -- If Size is set to size_t'Last on entry, then a Storage_Error
-- exception is raised with a message "object too large".
--
- -- If size_t is set to zero on entry, then a minimal (but non-zero)
+ -- If Size is set to zero on entry, then a minimal (but non-zero)
-- size block is allocated.
--
-- Note: this is roughly equivalent to the standard C malloc call
-- routine is guaranteed to be task safe, and also aborts are
-- deferred as necessary.
--
- -- If size_t is set to size_t'Last on entry, then a Storage_Error
+ -- If Size is set to size_t'Last on entry, then a Storage_Error
-- exception is raised with a message "object too large".
--
- -- If size_t is set to zero on entry, then a minimal (but non-zero)
+ -- If Size is set to zero on entry, then a minimal (but non-zero)
-- size block is allocated.
--
-- Note: this is roughly equivalent to the standard C realloc call
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
-- | | First (101)
-- +------------------+
-- +----------> | | |
- -- | +----------+-------+
+ -- | +--------- | ------+
+ -- | ^ |
-- | | |
- -- | ^ V
- -- | | |
- -- | +-------+----------+
+ -- | | V
+ -- | +------ | ---------+
-- | | | |
-- | +------------------+
-- | | | Last (100)
-- | | C |
-- | | H |
- -- +-----------------+ | +-------->| U |
- -- | Current_Chunk -|--+ | | N |
- -- +-----------------+ | | K |
- -- | Top -|-----+ | | First (1)
+ -- +-----------------+ | +------->| U |
+ -- | Current_Chunk ----+ | | N |
+ -- +-----------------+ | | K |
+ -- | Top --------+ | | First (1)
-- +-----------------+ +------------------+
-- | Default_Size | | Prev |
-- +-----------------+ +------------------+
(Addr : out Address;
Storage_Size : SSE.Storage_Count)
is
- Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);
- Max_Size : constant SS_Ptr :=
- ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align)
- * Max_Align;
+ Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);
+ Max_Size : constant SS_Ptr :=
+ ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) *
+ Max_Align;
begin
-- Case of fixed allocation secondary stack
Chunk := Stack.Current_Chunk;
-- The Current_Chunk may not be the good one if a lot of release
- -- operations have taken place. So go down the stack if necessary
+ -- operations have taken place. Go down the stack if necessary.
while Chunk.First > Stack.Top loop
Chunk := Chunk.Prev;
Free (To_Be_Released_Chunk);
end if;
- -- Create new chunk of default size unless it is not
- -- sufficient to satisfy the current request.
+ -- Create new chunk of default size unless it is not sufficient
+ -- to satisfy the current request.
elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
Chunk.Next :=
Chunk.Next.Prev := Chunk;
- -- Otherwise create new chunk of requested size
+ -- Otherwise create new chunk of requested size
else
Chunk.Next :=
Chunk : aliased Chunk_Id (1, Static_Secondary_Stack_Size);
for Chunk'Alignment use Standard'Maximum_Alignment;
- -- Default chunk used, unless gnatbind -D is specified with a value
- -- greater than Static_Secondary_Stack_Size
+ -- Default chunk used, unless gnatbind -D is specified with a value greater
+ -- than Static_Secondary_Stack_Size.
begin
declare
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
elsif Entry_Call.Mode /= Conditional_Call
or else not Entry_Call.With_Abort
then
-
if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
- and then
- Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
- Queuing.Count_Waiting (Object.Entry_Queues (E))
+ and then Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
+ Queuing.Count_Waiting (Object.Entry_Queues (E))
then
- -- This violates the Max_Entry_Queue_Length restriction,
- -- raise Program_Error.
+ -- This violates the Max_Entry_Queue_Length restriction, raise
+ -- Program_Error.
Entry_Call.Exception_To_Raise := Program_Error'Identity;
when N_Entry_Declaration =>
Analyze_Entry_Declaration (N);
- when N_Entry_Index_Specification =>
+ when N_Entry_Index_Specification =>
Analyze_Entry_Index_Specification (N);
when N_Enumeration_Representation_Clause =>
if Chars (N) /= TName then
if Present (Current_Entity (N))
- and then Is_Type (Current_Entity (N))
+ and then Is_Type (Current_Entity (N))
then
Freeze_Before (Freeze_Node (T), Current_Entity (N));
end if;
null;
elsif L /= Visible_Declarations (Parent (L))
- or else No (Private_Declarations (Parent (L)))
- or else Is_Empty_List (Private_Declarations (Parent (L)))
+ or else No (Private_Declarations (Parent (L)))
+ or else Is_Empty_List (Private_Declarations (Parent (L)))
then
Adjust_Decl;
Freeze_All (First_Entity (Current_Scope), Decl);
or else
Name_Buffer (3 .. 5) = "aux";
- -- If not an internal file, then entity is definitely known,
- -- even if it is in a private part (the message generated will
- -- note that it is in a private part)
+ -- If not an internal file, then entity is definitely known, even if
+ -- it is in a private part (the message generated will note that it
+ -- is in a private part).
else
return True;
null;
else
Error_Msg_N
- ("limited withed package can only be used to access "
- & "incomplete types", N);
+ ("limited withed package can only be used to access incomplete "
+ & "types", N);
end if;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
H := Current_Entity (Ent);
while Present (H) loop
- exit when (not Is_Overloadable (H))
- and then Is_Immediately_Visible (H);
+ exit when
+ not Is_Overloadable (H)
+ and then Is_Immediately_Visible (H);
if Is_Immediately_Visible (H) and then H /= Ent then
function New_Copy_Tree
(Source : Node_Id;
- Map : Elist_Id := No_Elist;
+ Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty) return Node_Id
+ New_Scope : Entity_Id := Empty) return Node_Id
is
Actual_Map : Elist_Id := Map;
-- This is the actual map for the copy. It is initialized with the
projects / gcc.git / commitdiff