+2017-01-13 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch6.adb (Freeze_Expr_Types): New subprogram.
+ (Analyze_Subprogram_Body_Helper): At the occurrence of an
+ expression function declaration that is a completion, its
+ expression causes freezing (AI12-0103).
+
+2017-01-13 Vadim Godunko <godunko@adacore.com>
+
+ * a-coinho-shared.adb: Fix memory leaks in Constant_Reference and
+ Reference functions of Ada.Containers.Indefinite_Holders.
+
+2017-01-13 Bob Duff <duff@adacore.com>
+
+ * s-os_lib.ads: Minor comment fixes.
+
+2017-01-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch3.adb (Default_Initialize_Object): Do not default
+ initialize an object when it is of a task type and restriction
+ No_Tasking is in effect because the initialization is obsolete.
+ * exp_ch9.adb (Build_Master_Entity): Do not generate a master when
+ restriction No_Tasking is in effect.
+ (Build_Master_Renaming): Do not rename a master when restriction
+ No_Tasking is in effect.
+
2017-01-13 Ed Schonberg <schonberg@adacore.com>
* sem_aggr.adb (Resolve_Array_Aggregate): The code that verifies
-- --
-- B o d y --
-- --
--- Copyright (C) 2013-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-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- --
procedure Free is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+ procedure Detach (Container : Holder);
+ -- Detach data from shared copy if necessary. This is necessary to prepare
+ -- container to be modified.
+
---------
-- "=" --
---------
begin
if Container.Reference = null then
raise Constraint_Error with "container is empty";
-
- elsif Container.Busy = 0
- and then not System.Atomic_Counters.Is_One
- (Container.Reference.Counter)
- then
- -- Container is not locked and internal shared object is used by
- -- other container, create copy of both internal shared object and
- -- element.
-
- Container'Unrestricted_Access.Reference :=
- new Shared_Holder'
- (Counter => <>,
- Element => new Element_Type'(Container.Reference.Element.all));
end if;
+ Detach (Container);
+
declare
Ref : constant Constant_Reference_Type :=
(Element => Container.Reference.Element.all'Access,
end if;
end Copy;
+ ------------
+ -- Detach --
+ ------------
+
+ procedure Detach (Container : Holder) is
+ begin
+ if Container.Busy = 0
+ and then not System.Atomic_Counters.Is_One
+ (Container.Reference.Counter)
+ then
+ -- Container is not locked and internal shared object is used by
+ -- other container, create copy of both internal shared object and
+ -- element.
+
+ declare
+ Old : constant Shared_Holder_Access := Container.Reference;
+
+ begin
+ Container'Unrestricted_Access.Reference :=
+ new Shared_Holder'
+ (Counter => <>,
+ Element =>
+ new Element_Type'(Container.Reference.Element.all));
+ Unreference (Old);
+ end;
+ end if;
+ end Detach;
+
-------------
-- Element --
-------------
begin
if Container.Reference = null then
raise Constraint_Error with "container is empty";
-
- elsif Container.Busy = 0
- and then
- not System.Atomic_Counters.Is_One (Container.Reference.Counter)
- then
- -- Container is not locked and internal shared object is used by
- -- other container, create copy of both internal shared object and
- -- element.
-
- Container'Unrestricted_Access.Reference :=
- new Shared_Holder'
- (Counter => <>,
- Element => new Element_Type'(Container.Reference.Element.all));
end if;
+ Detach (Container);
+
B := B + 1;
begin
begin
if Container.Reference = null then
raise Constraint_Error with "container is empty";
-
- elsif Container.Busy = 0
- and then
- not System.Atomic_Counters.Is_One (Container.Reference.Counter)
- then
- -- Container is not locked and internal shared object is used by
- -- other container, create copy of both internal shared object and
- -- element.
-
- Container.Reference :=
- new Shared_Holder'
- (Counter => <>,
- Element => new Element_Type'(Container.Reference.Element.all));
end if;
+ Detach (Container);
+
declare
Ref : constant Reference_Type :=
(Element => Container.Reference.Element.all'Access,
begin
if Container.Reference = null then
raise Constraint_Error with "container is empty";
-
- elsif Container.Busy = 0
- and then
- not System.Atomic_Counters.Is_One (Container.Reference.Counter)
- then
- -- Container is not locked and internal shared object is used by
- -- other container, create copy of both internal shared object and
- -- element.
-
- Container'Unrestricted_Access.Reference :=
- new Shared_Holder'
- (Counter => <>,
- Element => new Element_Type'(Container.Reference.Element.all));
end if;
+ Detach (Container);
+
B := B + 1;
begin
if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then
return;
+
+ -- Nothing to do if the object being initializes is of a task type
+ -- and restriction No_Tasking is in effect because this is a direct
+ -- violation of the restriction.
+
+ elsif Is_Task_Type (Base_Typ)
+ and then Restriction_Active (No_Tasking)
+ then
+ return;
end if;
-- The expansion performed by this routine is as follows:
Find_Enclosing_Context (Par, Context, Context_Id, Decls);
end if;
- -- Do not create a master if one already exists or there is no task
- -- hierarchy.
+ -- Nothing to do if the context already has a master
- if Has_Master_Entity (Context_Id)
+ if Has_Master_Entity (Context_Id) then
+ return;
+
+ -- Nothing to do if tasks or tasking hierarchies are prohibited
+
+ elsif Restriction_Active (No_Tasking)
or else Restriction_Active (No_Task_Hierarchy)
then
return;
Master_Id : Entity_Id;
begin
- -- Nothing to do if there is no task hierarchy
+ -- Nothing to do if tasks or tasking hierarchies are prohibited
- if Restriction_Active (No_Task_Hierarchy) then
+ if Restriction_Active (No_Tasking)
+ or else Restriction_Active (No_Task_Hierarchy)
+ then
return;
end if;
function File_Time_Stamp (Name : String) return OS_Time;
-- Given the name of a file or directory, Name, obtains and returns the
-- time stamp. This function can be used for an unopened file. Returns
- -- Invalid_Time is Name doesn't correspond to an existing file.
+ -- Invalid_Time if Name doesn't correspond to an existing file.
function File_Time_Stamp (FD : File_Descriptor) return OS_Time;
-- Get time stamp of file from file descriptor FD Returns Invalid_Time is
-- This subtype is used to document that a parameter is the address of a
-- null-terminated string containing the name of a file.
- -- All the following functions need comments ???
-
procedure Copy_File
(Name : C_File_Name;
Pathname : C_File_Name;
procedure Delete_File (Name : C_File_Name; Success : out Boolean);
function File_Time_Stamp (Name : C_File_Name) return OS_Time;
- -- Returns Invalid_Time is Name doesn't correspond to an existing file
function Is_Directory (Name : C_File_Name) return Boolean;
function Is_Executable_File (Name : C_File_Name) return Boolean;
-- Function result subtype
procedure Check_Aggregate_Accessibility (Aggr : Node_Id);
- -- Apply legality rule of 6.5 (8.2) to the access discriminants of an
+ -- Apply legality rule of 6.5 (5.8) to the access discriminants of an
-- aggregate in a return statement.
procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
-- limited views with the non-limited ones. Return the list of changes
-- to be used to undo the transformation.
+ procedure Freeze_Expr_Types (Spec_Id : Entity_Id);
+ -- (AI12-0103) N is the body associated with an expression function that
+ -- is a completion, and Spec_Id its defining entity. Freeze before N all
+ -- the types referenced by the expression of the function.
+
function Is_Private_Concurrent_Primitive
(Subp_Id : Entity_Id) return Boolean;
-- Determine whether subprogram Subp_Id is a primitive of a concurrent
return Result;
end Exchange_Limited_Views;
+ -----------------------
+ -- Freeze_Expr_Types --
+ -----------------------
+
+ procedure Freeze_Expr_Types (Spec_Id : Entity_Id) is
+ function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result;
+ -- Freeze all types referenced in the subtree rooted at Node
+
+ ----------------------
+ -- Freeze_Type_Refs --
+ ----------------------
+
+ function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (Node) = N_Identifier
+ and then Present (Entity (Node))
+ then
+ if Is_Type (Entity (Node)) then
+ Freeze_Before (N, Entity (Node));
+
+ elsif Ekind_In (Entity (Node), E_Component,
+ E_Discriminant)
+ then
+ Freeze_Before (N, Scope (Entity (Node)));
+ end if;
+ end if;
+
+ return OK;
+ end Freeze_Type_Refs;
+
+ procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs);
+
+ -- Local variables
+
+ Return_Stmt : constant Node_Id :=
+ First (Statements (Handled_Statement_Sequence (N)));
+ Dup_Expr : constant Node_Id :=
+ New_Copy_Tree (Expression (Return_Stmt));
+
+ Saved_First_Entity : constant Entity_Id := First_Entity (Spec_Id);
+ Saved_Last_Entity : constant Entity_Id := Last_Entity (Spec_Id);
+
+ -- Start of processing for Freeze_Expr_Types
+
+ begin
+ pragma Assert (Nkind (Return_Stmt) = N_Simple_Return_Statement);
+
+ -- Preanalyze a duplicate of the expression to have available the
+ -- minimum decoration needed to locate referenced unfrozen types
+ -- without adding any decoration to the function expression. This
+ -- preanalysis is performed with errors disabled to avoid reporting
+ -- spurious errors on Ghost entities (since the expression is not
+ -- fully analyzed).
+
+ Push_Scope (Spec_Id);
+ Install_Formals (Spec_Id);
+ Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
+
+ Preanalyze_Spec_Expression (Dup_Expr, Etype (Spec_Id));
+
+ Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
+ End_Scope;
+
+ -- Restore certain attributes of Spec_Id since the preanalysis may
+ -- have introduced itypes to this scope, thus modifying attributes
+ -- First_Entity and Last_Entity.
+
+ Set_First_Entity (Spec_Id, Saved_First_Entity);
+ Set_Last_Entity (Spec_Id, Saved_Last_Entity);
+
+ -- Freeze all types referenced in the expression
+
+ Freeze_References (Dup_Expr);
+ end Freeze_Expr_Types;
+
-------------------------------------
-- Is_Private_Concurrent_Primitive --
-------------------------------------
then
Set_Has_Delayed_Freeze (Spec_Id);
Freeze_Before (N, Spec_Id);
+
+ -- At the occurrence of an expression function declaration that is
+ -- a completion, its expression causes freezing (AI12-0103).
+
+ if Has_Completion (Spec_Id)
+ and then Was_Expression_Function (N)
+ then
+ Freeze_Expr_Types (Spec_Id);
+ end if;
end if;
end if;
projects / gcc.git / commitdiff