+2017-01-23 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_strm.ads: Minor reformatting and typo fixes.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_aggr.adb, par_sco.adb, exp_util.adb, sem.adb, sem_ch4.adb,
+ exp_aggr.adb: Minor reformatting.
+ * g-diopit.adb: minor grammar/punctuation fix in comment.
+ * g-byorma.ads: minor fix of unbalanced parens in comment.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * par.adb: Update the documentation of component Labl.
+ * par-ch6.adb (P_Return_Statement): Set the expected label of
+ an extended return statement to Error.
+
+2017-01-23 Tristan Gingold <gingold@adacore.com>
+
+ * s-boustr.ads, s-boustr.adb (Is_Full): New function.
+
+2017-01-23 Ed Schonberg <schonberg@adacore.com>
+
+ * expander.adb: Handle N_Delta_Aggregate.
+
+2017-01-23 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch6.adb (Expand_Call): Improve the code that
+ checks if some formal of the called subprogram is a class-wide
+ interface, to handle subtypes of class-wide interfaces.
+
+2017-01-23 Javier Miranda <miranda@adacore.com>
+
+ * checks.adb (Apply_Parameter_Aliasing_Checks):
+ Remove side effects of the actuals before generating the overlap
+ check.
+
2017-01-23 Justin Squirek <squirek@adacore.com>
* exp_strm.ads, exp_strm.ads
and then not Is_Elementary_Type (Etype (Orig_Act_2))
and then May_Cause_Aliasing (Formal_1, Formal_2)
then
+ Remove_Side_Effects (Actual_1);
+ Remove_Side_Effects (Actual_2);
+
Overlap_Check
(Actual_1 => Actual_1,
Actual_2 => Actual_2,
------------------------------
procedure Expand_N_Delta_Aggregate (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Temp : constant Entity_Id := Make_Temporary (Loc, 'T');
- Typ : constant Entity_Id := Etype (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
Decl : Node_Id;
begin
- Decl := Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition => New_Occurrence_Of (Typ, Loc),
- Expression => New_Copy_Tree (Expression (N)));
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'T'),
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => New_Copy_Tree (Expression (N)));
if Is_Array_Type (Etype (N)) then
Expand_Delta_Array_Aggregate (N, New_List (Decl));
----------------------------------
procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Temp : constant Entity_Id := Defining_Identifier (First (Deltas));
- Assoc : Node_Id;
- Choice : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Temp : constant Entity_Id := Defining_Identifier (First (Deltas));
+ Assoc : Node_Id;
+
function Generate_Loop (C : Node_Id) return Node_Id;
-- Generate a loop containing individual component assignments for
-- choices that are ranges, subtype indications, subtype names, and
-- iterated component associations.
+ -------------------
+ -- Generate_Loop --
+ -------------------
+
function Generate_Loop (C : Node_Id) return Node_Id is
Sl : constant Source_Ptr := Sloc (C);
Ix : Entity_Id;
return
Make_Loop_Statement (Loc,
- Iteration_Scheme => Make_Iteration_Scheme (Sl,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Sl,
- Defining_Identifier => Ix,
- Discrete_Subtype_Definition => New_Copy_Tree (C))),
- End_Label => Empty,
- Statements =>
- New_List (
- Make_Assignment_Statement (Sl,
- Name => Make_Indexed_Component (Sl,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Sl,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Sl,
+ Defining_Identifier => Ix,
+ Discrete_Subtype_Definition => New_Copy_Tree (C))),
+
+ Statements => New_List (
+ Make_Assignment_Statement (Sl,
+ Name =>
+ Make_Indexed_Component (Sl,
Prefix => New_Occurrence_Of (Temp, Sl),
Expressions => New_List (New_Occurrence_Of (Ix, Sl))),
- Expression => New_Copy_Tree (Expression (Assoc)))));
+ Expression => New_Copy_Tree (Expression (Assoc)))),
+ End_Label => Empty);
end Generate_Loop;
+ -- Local variables
+
+ Choice : Node_Id;
+
+ -- Start of processing for Expand_Delta_Array_Aggregate
+
begin
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
if Nkind (Choice) = N_Range
or else (Is_Entity_Name (Choice)
- and then Is_Type (Entity (Choice)))
+ and then Is_Type (Entity (Choice)))
then
Append_To (Deltas, Generate_Loop (Choice));
else
Append_To (Deltas,
- Make_Assignment_Statement (Sloc (Choice),
- Name => Make_Indexed_Component (Sloc (Choice),
- Prefix => New_Occurrence_Of (Temp, Loc),
- Expressions => New_List (New_Copy_Tree (Choice))),
- Expression => New_Copy_Tree (Expression (Assoc))));
+ Make_Assignment_Statement (Sloc (Choice),
+ Name =>
+ Make_Indexed_Component (Sloc (Choice),
+ Prefix => New_Occurrence_Of (Temp, Loc),
+ Expressions => New_List (New_Copy_Tree (Choice))),
+ Expression => New_Copy_Tree (Expression (Assoc))));
end if;
Next (Choice);
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
Append_To (Deltas,
- Make_Assignment_Statement (Sloc (Choice),
- Name => Make_Selected_Component (Sloc (Choice),
- Prefix => New_Occurrence_Of (Temp, Loc),
- Selector_Name => Make_Identifier (Loc, Chars (Choice))),
- Expression => New_Copy_Tree (Expression (Assoc))));
+ Make_Assignment_Statement (Sloc (Choice),
+ Name =>
+ Make_Selected_Component (Sloc (Choice),
+ Prefix => New_Occurrence_Of (Temp, Loc),
+ Selector_Name => Make_Identifier (Loc, Chars (Choice))),
+ Expression => New_Copy_Tree (Expression (Assoc))));
Next (Choice);
end loop;
CW_Interface_Formals_Present :=
CW_Interface_Formals_Present
or else
- (Ekind (Etype (Formal)) = E_Class_Wide_Type
+ (Is_Class_Wide_Type (Etype (Formal))
and then Is_Interface (Etype (Etype (Formal))))
or else
(Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+ and then Is_Class_Wide_Type (Directly_Designated_Type
+ (Etype (Etype (Formal))))
and then Is_Interface (Directly_Designated_Type
(Etype (Etype (Formal)))));
Fnam : out Entity_Id;
Use_Underlying : Boolean := True);
-- Build function for Input attribute for record type or for an elementary
- -- type (the latter is used only in the case where a user defined Read
- -- routine is defined, since in other cases, Input calls the appropriate
- -- runtime library routine directly. The flag Use_Underlying controls
- -- weither the base type or the underlying type of the base type of Typ is
+ -- type (the latter is used only in the case where a user-defined Read
+ -- routine is defined, since, in other cases, Input calls the appropriate
+ -- runtime library routine directly). The flag Use_Underlying controls
+ -- whether the base type or the underlying type of the base type of Typ is
-- used during construction.
procedure Build_Record_Or_Elementary_Output_Procedure
-- Nothing to be done if no underlying record view available
-- If this is a limited type derived from a type with unknown
- -- discriminants, do not expand either, so that subsequent
- -- expansion of the call can add build-in-place parameters to call.
+ -- discriminants, do not expand either, so that subsequent expansion
+ -- of the call can add build-in-place parameters to call.
if No (Underlying_Record_View (Unc_Type))
or else Is_Limited_Type (Unc_Type)
when N_Delay_Until_Statement =>
Expand_N_Delay_Until_Statement (N);
+ when N_Delta_Aggregate =>
+ Expand_N_Delta_Aggregate (N);
+
when N_Entry_Body =>
Expand_N_Entry_Body (N);
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2013, AdaCore --
+-- Copyright (C) 2006-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- --
-- This package provides a procedure for reading and interpreting the BOM
-- (byte order mark) used to publish the encoding method for a string (for
-- example, a UTF-8 encoded file in windows will start with the appropriate
--- BOM sequence to signal UTF-8 encoding.
+-- BOM sequence to signal UTF-8 encoding).
-- There are two cases
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2015, AdaCore --
+-- Copyright (C) 2001-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- --
(Directory : String;
File_Pattern : String;
Suffix_Pattern : String);
- -- Read entries in Directory and call user's callback if the entry
- -- match File_Pattern and Suffix_Pattern is empty otherwise it will go
- -- down one more directory level by calling Next_Level routine above.
+ -- Read entries in Directory and call user's callback if the entry match
+ -- File_Pattern and Suffix_Pattern is empty; otherwise go down one more
+ -- directory level by calling Next_Level routine below.
procedure Next_Level
(Current_Path : String;
("aspect specifications must come after initialization "
& "expression",
Sloc (First (Aspect_Specifications (Decl_Node))));
+
+ else
+ -- In any case, the assignment symbol doesn't belong.
+
+ Error_Msg ("misplaced assignment symbol", Scan_Ptr);
end if;
Set_Expression (Decl_Node, Init_Expr_Opt);
-- --
-- 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- --
if Token = Tok_Do then
Push_Scope_Stack;
- Scope.Table (Scope.Last).Etyp := E_Return;
Scope.Table (Scope.Last).Ecol := Ret_Strt;
+ Scope.Table (Scope.Last).Etyp := E_Return;
+ Scope.Table (Scope.Last).Labl := Error;
Scope.Table (Scope.Last).Sloc := Ret_Sloc;
Scan; -- past DO
-- subprogram specifications and bodies the field holds the correponding
-- program unit name. For task declarations and bodies, protected types
-- and bodies, and accept statements the field hold the name of the type
- -- or operation. For if-statements, case-statements, and selects, the
- -- field is initialized to Error.
+ -- or operation. For if-statements, case-statements, return statements,
+ -- and selects, the field is initialized to Error.
-- Note: this is a bit of an odd (mis)use of Error, since there is no
-- Error, but we use this value as a place holder to indicate that it
-- Record first entries used in SC/SD at this recursive level
procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
- -- Extend the current statement sequence to encompass the node N. Typ
- -- is the letter that identifies the type of statement/declaration that
- -- is being added to the sequence.
+ -- Extend the current statement sequence to encompass the node N. Typ is
+ -- the letter that identifies the type of statement/declaration that is
+ -- being added to the sequence.
procedure Process_Decisions_Defer (N : Node_Id; T : Character);
pragma Inline (Process_Decisions_Defer);
-- Helper for Traverse_One: traverse N's aspect specifications
procedure Traverse_Degenerate_Subprogram (N : Node_Id);
- -- Common code to handle null procedures and expression functions.
- -- Emit a SCO of the given Kind and N outside of the dominance flow.
+ -- Common code to handle null procedures and expression functions. Emit
+ -- a SCO of the given Kind and N outside of the dominance flow.
-------------------------------
-- Extend_Statement_Sequence --
-- Save last statement in current sequence as dominant
begin
- -- Output statement SCO for degenerate subprogram body
- -- (null statement or freestanding expression) outside of
- -- the dominance chain.
+ -- Output statement SCO for degenerate subprogram body (null
+ -- statement or freestanding expression) outside of the dominance
+ -- chain.
Current_Dominant := No_Dominant;
Extend_Statement_Sequence (N, Typ => ' ');
if Nkind (N) in N_Subexpr then
Process_Decisions_Defer (N, 'X');
end if;
+
Set_Statement_Entry;
- -- Restore current dominant information designating last
- -- statement in previous sequence (i.e. make the dominance
- -- chain skip over the degenerate body).
+ -- Restore current dominant information designating last statement
+ -- in previous sequence (i.e. make the dominance chain skip over
+ -- the degenerate body).
Current_Dominant := Saved_Dominant;
end;
-- Subprogram declaration or subprogram body stub
- when N_Subprogram_Body_Stub
+ when N_Expression_Function
+ | N_Subprogram_Body_Stub
| N_Subprogram_Declaration
- | N_Expression_Function
=>
declare
Spec : constant Node_Id := Specification (N);
then
Traverse_Degenerate_Subprogram (N);
- -- Case of an expression function: generate a statement
- -- SCO for the expression (and then decision SCOs for any
- -- nested decisions).
+ -- Case of an expression function: generate a statement SCO
+ -- for the expression (and then decision SCOs for any nested
+ -- decisions).
elsif Nkind (N) = N_Expression_Function then
Traverse_Degenerate_Subprogram (Expression (N));
Append (X, S (P - 1 .. S'Last));
end Append_Address;
+ -------------
+ -- Is_Full --
+ -------------
+
+ function Is_Full (X : Bounded_String) return Boolean is
+ begin
+ return X.Length >= X.Max_Length;
+ end Is_Full;
+
---------------
-- To_String --
---------------
procedure Append_Address (X : in out Bounded_String; A : Address);
-- Append an address to X
+ function Is_Full (X : Bounded_String) return Boolean;
+ -- Return True iff X is full and any character or string will be dropped
+ -- if appended.
private
type Bounded_String (Max_Length : Natural) is limited record
Length : Natural := 0;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-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- --
pragma Import (C, getpid, "getpid");
PR_SET_NAME : constant := 15;
+ PR_GET_NAME : constant := 16;
function prctl
(option : int;
Self_ID.Common.LL.Thread := pthread_self;
Self_ID.Common.LL.LWP := lwp_self;
- if Self_ID.Common.Task_Image_Len > 0 then
+ -- Set thread name to ease debugging. If the name of the task is
+ -- "foreign thread" (as set by Register_Foreign_Thread) retrieve
+ -- the name of the thread and update the name of the task instead.
+
+ if Self_ID.Common.Task_Image_Len = 14
+ and then Self_ID.Common.Task_Image (1 .. 14) = "foreign thread"
+ then
+ declare
+ Thread_Name : String (1 .. 16);
+ -- PR_GET_NAME returns a string of up to 16 bytes
+
+ Len : Natural := 0;
+ -- Length of the task name contained in Task_Name
+
+ Result : int;
+ -- Result from the prctl call
+ begin
+ Result := prctl (PR_GET_NAME, unsigned_long (Thread_Name'Address));
+ pragma Assert (Result = 0);
+
+ -- Find the length of the given name
+
+ for J in Thread_Name'Range loop
+ if Thread_Name (J) /= ASCII.NUL then
+ Len := Len + 1;
+ else
+ exit;
+ end if;
+ end loop;
+
+ -- Cover the odd situtation if someone decides to change
+ -- Parameters.Max_Task_Image_Length to less than 16 characters
+
+ if Len > Parameters.Max_Task_Image_Length then
+ Len := Parameters.Max_Task_Image_Length;
+ end if;
+
+ -- Copy the name of the thread to the task's ATCB
+
+ Self_ID.Common.Task_Image (1 .. Len) := Thread_Name (1 .. Len);
+ Self_ID.Common.Task_Image_Len := Len;
+ end;
+
+ elsif Self_ID.Common.Task_Image_Len > 0 then
declare
Task_Name : String (1 .. Parameters.Max_Task_Image_Length + 1);
Result : int;
begin
- -- Set thread name to ease debugging
-
Task_Name (1 .. Self_ID.Common.Task_Image_Len) :=
Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len);
Task_Name (Self_ID.Common.Task_Image_Len + 1) := ASCII.NUL;
when N_Delay_Relative_Statement =>
Analyze_Delay_Relative (N);
- when N_Delta_Aggregate =>
- Analyze_Aggregate (N);
-
when N_Delay_Until_Statement =>
Analyze_Delay_Until (N);
+ when N_Delta_Aggregate =>
+ Analyze_Aggregate (N);
+
when N_Entry_Body =>
Analyze_Entry_Body (N);
-----------------------------
procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Base : constant Node_Id := Expression (N);
- Deltas : constant List_Id := Component_Associations (N);
- Assoc : Node_Id;
- Choice : Node_Id;
- Comp_Type : Entity_Id;
- Index_Type : Entity_Id;
+ Base : constant Node_Id := Expression (N);
+ Deltas : constant List_Id := Component_Associations (N);
function Get_Component_Type (Nam : Node_Id) return Entity_Id;
return Any_Type;
end Get_Component_Type;
+ -- Local variables
+
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Comp_Type : Entity_Id;
+ Index_Type : Entity_Id;
+
+ -- Start of processing for Resolve_Delta_Aggregate
+
begin
if not Is_Composite_Type (Typ) then
Error_Msg_N ("not a composite type", N);
end if;
Analyze_And_Resolve (Base, Typ);
+
if Is_Array_Type (Typ) then
Index_Type := Etype (First_Index (Typ));
Assoc := First (Deltas);
end loop;
declare
- Id : constant Entity_Id := Defining_Identifier (Assoc);
- Ent : constant Entity_Id :=
- New_Internal_Entity
- (E_Loop, Current_Scope, Sloc (Assoc), 'L');
+ Id : constant Entity_Id := Defining_Identifier (Assoc);
+ Ent : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Loop, Current_Scope, Sloc (Assoc), 'L');
begin
Set_Etype (Ent, Standard_Void_Type);
if Base_Type (Entity (Choice)) /=
Base_Type (Index_Type)
then
- Error_Msg_NE ("choice does mat match index type of",
- Choice, Typ);
+ Error_Msg_NE
+ ("choice does mat match index type of",
+ Choice, Typ);
end if;
else
Resolve (Choice, Index_Type);
Typ := Corresponding_Record_Type (Typ);
end if;
- -- Simple case. Object may be a subtype of the tagged type or
- -- may be the corresponding record of a synchronized type.
+ -- Simple case. Object may be a subtype of the tagged type or may
+ -- be the corresponding record of a synchronized type.
return Obj_Type = Typ
or else Base_Type (Obj_Type) = Typ
or else Corr_Type = Typ
-- Object may be of a derived type whose parent has unknown
- -- discriminants, in which case the type matches the
- -- underlying record view of its base.
+ -- discriminants, in which case the type matches the underlying
+ -- record view of its base.
- or else (Has_Unknown_Discriminants (Typ)
- and then Typ = Underlying_Record_View (Base_Type (Obj_Type)))
+ or else
+ (Has_Unknown_Discriminants (Typ)
+ and then Typ = Underlying_Record_View (Base_Type (Obj_Type)))
-- Prefix can be dereferenced
(Is_Access_Type (Corr_Type)
and then Designated_Type (Corr_Type) = Typ)
- -- Formal is an access parameter, for which the object
- -- can provide an access.
+ -- Formal is an access parameter, for which the object can
+ -- provide an access.
or else
(Ekind (Typ) = E_Anonymous_Access_Type
projects / gcc.git / commitdiff