Commit c7518e6f by Arnaud Charlet

[multiple changes]

2016-04-27  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Export_Import): Signal that there is no
	corresponding pragma.

2016-04-27  Bob Duff  <duff@adacore.com>

	* exp_ch3.adb: Minor comment improvement.

2016-04-27  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): If the
	return type is an untagged limited record with only access
	discriminants and no controlled components, the return value does not
	need to use the secondary stack.

2016-04-27  Javier Miranda  <miranda@adacore.com>

	* exp_util.adb (Remove_Side_Effects): When
	generating C code handle object declarations that have
	discriminants and are initialized by means of a call to a
	function.

2016-04-27  Ed Schonberg  <schonberg@adacore.com>

	* a-textio.adb (Get_Line function): Handle properly the case of
	a line that has the same length as the buffer (or a multiple
	thereof) and there is no line terminator.
	* a-tigeli.adb (Get_Line procedure): Do not store an end_of_file
	in the string when there is no previous line terminator and we
	need at most one additional character.

From-SVN: r235492
parent 814cc240
2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Export_Import): Signal that there is no
corresponding pragma.
2016-04-27 Bob Duff <duff@adacore.com>
* exp_ch3.adb: Minor comment improvement.
2016-04-27 Ed Schonberg <schonberg@adacore.com>
* exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): If the
return type is an untagged limited record with only access
discriminants and no controlled components, the return value does not
need to use the secondary stack.
2016-04-27 Javier Miranda <miranda@adacore.com>
* exp_util.adb (Remove_Side_Effects): When
generating C code handle object declarations that have
discriminants and are initialized by means of a call to a
function.
2016-04-27 Ed Schonberg <schonberg@adacore.com>
* a-textio.adb (Get_Line function): Handle properly the case of
a line that has the same length as the buffer (or a multiple
thereof) and there is no line terminator.
* a-tigeli.adb (Get_Line procedure): Do not store an end_of_file
in the string when there is no previous line terminator and we
need at most one additional character.
2016-04-27 Arnaud Charlet <charlet@adacore.com> 2016-04-27 Arnaud Charlet <charlet@adacore.com>
* s-rident.ads: Make No_Implicit_Loops non partition wide. * s-rident.ads: Make No_Implicit_Loops non partition wide.
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -704,9 +704,6 @@ package body Ada.Text_IO is ...@@ -704,9 +704,6 @@ package body Ada.Text_IO is
end Get_Line; end Get_Line;
function Get_Line (File : File_Type) return String is function Get_Line (File : File_Type) return String is
Buffer : String (1 .. 500);
Last : Natural;
function Get_Rest (S : String) return String; function Get_Rest (S : String) return String;
-- This is a recursive function that reads the rest of the line and -- This is a recursive function that reads the rest of the line and
-- returns it. S is the part read so far. -- returns it. S is the part read so far.
...@@ -732,12 +729,19 @@ package body Ada.Text_IO is ...@@ -732,12 +729,19 @@ package body Ada.Text_IO is
begin begin
if Last < Buffer'Last then if Last < Buffer'Last then
return R; return R;
else else
return Get_Rest (R); return Get_Rest (R);
end if; end if;
end; end;
end Get_Rest; end Get_Rest;
-- Local variables
Buffer : String (1 .. 500);
ch : int;
Last : Natural;
-- Start of processing for Get_Line -- Start of processing for Get_Line
begin begin
...@@ -745,6 +749,22 @@ package body Ada.Text_IO is ...@@ -745,6 +749,22 @@ package body Ada.Text_IO is
if Last < Buffer'Last then if Last < Buffer'Last then
return Buffer (1 .. Last); return Buffer (1 .. Last);
-- If the String has the same length as the buffer, and there is no end
-- of line, check whether we are at the end of file, in which case we
-- have the full String in the buffer.
elsif Last = Buffer'Last then
ch := Getc (File);
if ch = EOF then
return Buffer;
else
Ungetc (ch, File);
return Get_Rest (Buffer (1 .. Last));
end if;
else else
return Get_Rest (Buffer (1 .. Last)); return Get_Rest (Buffer (1 .. Last));
end if; end if;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -187,8 +187,13 @@ begin ...@@ -187,8 +187,13 @@ begin
-- If we get EOF after already reading data, this is an incomplete -- If we get EOF after already reading data, this is an incomplete
-- last line, in which case no End_Error should be raised. -- last line, in which case no End_Error should be raised.
if ch = EOF and then Last < Item'First then if ch = EOF then
raise End_Error; if Last < Item'First then
raise End_Error;
else -- All done
return;
end if;
elsif ch /= LM then elsif ch /= LM then
......
...@@ -7108,8 +7108,10 @@ package body Exp_Ch3 is ...@@ -7108,8 +7108,10 @@ package body Exp_Ch3 is
end; end;
end if; end if;
-- Final transformation - turn the object declaration into a renaming if -- Final transformation - turn the object declaration into a renaming
-- appropriate. -- if appropriate. If this is the completion of a deferred constant
-- declaration, then this transformation generates what would be
-- illegal code if written by hand, but that's OK.
if Present (Expr) then if Present (Expr) then
if Rewrite_As_Renaming then if Rewrite_As_Renaming then
......
...@@ -7783,7 +7783,12 @@ package body Exp_Ch6 is ...@@ -7783,7 +7783,12 @@ package body Exp_Ch6 is
Result_Subt : Entity_Id; Result_Subt : Entity_Id;
Definite : Boolean; Definite : Boolean;
-- True for definite function result subtype -- True if result subtype is definite, or has a size that does not
-- require secondary stack usage (i.e. no variant part or components
-- whose type depends on discriminants). In particular, untagged types
-- with only access discriminants do not require secondary stack use.
-- Note that if the return type is tagged we must always use the sec.
-- stack because the call may dispatch on result.
begin begin
-- Step past qualification or unchecked conversion (the latter can occur -- Step past qualification or unchecked conversion (the latter can occur
...@@ -7818,7 +7823,10 @@ package body Exp_Ch6 is ...@@ -7818,7 +7823,10 @@ package body Exp_Ch6 is
end if; end if;
Result_Subt := Etype (Function_Id); Result_Subt := Etype (Function_Id);
Definite := Is_Definite_Subtype (Underlying_Type (Result_Subt)); Definite :=
(Is_Definite_Subtype (Underlying_Type (Result_Subt))
and then not Is_Tagged_Type (Result_Subt))
or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
-- Create an access type designating the function's result subtype. We -- Create an access type designating the function's result subtype. We
-- use the type of the original call because it may be a call to an -- use the type of the original call because it may be a call to an
......
...@@ -7944,13 +7944,35 @@ package body Exp_Util is ...@@ -7944,13 +7944,35 @@ package body Exp_Util is
else else
-- An expression which is in SPARK mode is considered side effect -- An expression which is in SPARK mode is considered side effect
-- free if the resulting value is captured by a variable or a -- free if the resulting value is captured by a variable or a
-- constant. Same reasoning when generating C code. -- constant.
-- Why can't we apply this test in general???
if (GNATprove_Mode or Generate_C_Code) if GNATprove_Mode
and then Nkind (Parent (Exp)) = N_Object_Declaration and then Nkind (Parent (Exp)) = N_Object_Declaration
then then
goto Leave; goto Leave;
-- When generating C code we cannot consider side effect free object
-- declarations that have discriminants and are initialized by means
-- of a function call since on this target there is no secondary
-- stack to store the return value and the expander may generate an
-- extra call to the function to compute the discriminant value. In
-- addition, for targets that have secondary stack, the expansion of
-- functions with side effects involves the generation of an access
-- type to capture the return value stored in the secondary stack;
-- by contrast when generating C code such expansion generates an
-- internal object declaration (no access type involved) which must
-- be identified here to avoid entering into a never-ending loop
-- generating internal object declarations.
elsif Generate_C_Code
and then Nkind (Parent (Exp)) = N_Object_Declaration
and then
(Nkind (Exp) /= N_Function_Call
or else not Has_Discriminants (Exp_Type)
or else Is_Internal_Name
(Chars (Defining_Identifier (Parent (Exp)))))
then
goto Leave;
end if; end if;
-- Special processing for function calls that return a limited type. -- Special processing for function calls that return a limited type.
...@@ -8063,12 +8085,39 @@ package body Exp_Util is ...@@ -8063,12 +8085,39 @@ package body Exp_Util is
Set_Analyzed (E, False); Set_Analyzed (E, False);
end if; end if;
Insert_Action (Exp, -- Generating C code of object declarations that have discriminants
Make_Object_Declaration (Loc, -- and are initialized by means of a function call we propagate the
Defining_Identifier => Def_Id, -- discriminants of the parent type to the internally built object.
Object_Definition => New_Occurrence_Of (Ref_Type, Loc), -- This is needed to avoid generating an extra call to the called
Constant_Present => True, -- function.
Expression => New_Exp));
-- For example, if we generate here the following declaration, it
-- will be expanded later adding an extra call to evaluate the value
-- of the discriminant (needed to compute the size of the object).
--
-- type Rec (D : Integer) is ...
-- Obj : constant Rec := SomeFunc;
if Generate_C_Code
and then Nkind (Parent (Exp)) = N_Object_Declaration
and then Has_Discriminants (Exp_Type)
and then Nkind (Exp) = N_Function_Call
then
Insert_Action (Exp,
Make_Object_Declaration (Loc,
Defining_Identifier => Def_Id,
Object_Definition => New_Copy_Tree
(Object_Definition (Parent (Exp))),
Constant_Present => True,
Expression => New_Exp));
else
Insert_Action (Exp,
Make_Object_Declaration (Loc,
Defining_Identifier => Def_Id,
Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
Constant_Present => True,
Expression => New_Exp));
end if;
end if; end if;
-- Preserve the Assignment_OK flag in all copies, since at least one -- Preserve the Assignment_OK flag in all copies, since at least one
......
...@@ -1691,6 +1691,12 @@ package body Sem_Ch13 is ...@@ -1691,6 +1691,12 @@ package body Sem_Ch13 is
-- into account Conversion, External_Name, and Link_Name. -- into account Conversion, External_Name, and Link_Name.
Aitem := Build_Export_Import_Pragma (Aspect, E); Aitem := Build_Export_Import_Pragma (Aspect, E);
-- Otherwise the expression is either False or erroneous. There
-- is no corresponding pragma.
else
Aitem := Empty;
end if; end if;
end Analyze_Aspect_Export_Import; end Analyze_Aspect_Export_Import;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment