Commit 9d2a2071 by Arnaud Charlet

[multiple changes]

2014-07-31  Robert Dewar  <dewar@adacore.com>

	* frontend.adb: Minor reformatting.
	* sem.adb: Minor reformatting.
	* sem_ch6.adb (Analyze_Null_Procedure): Set proper sloc for
	identifiers on rewrite.
	* par.adb: Minor comment updates.
	* a-ngelfu.adb (Cos): Minor simplification.
	* par-ch13.adb (Get_Aspect_Specifications): Improve messages
	and recovery for bad aspect.
	* exp_ch3.adb: Code clean up.
	* sem_util.ads: Minor comment correction.
	* sem_ch13.adb (Check_Array_Type): Properly handle large types.
	* sem_ch3.adb: Code clean up.
	* binderr.ads: Minor comment correction.

2014-07-31  Ed Schonberg  <schonberg@adacore.com>

	* exp_disp.adb (Expand_Interface_Conversion): A call whose
	prefix is a static conversion to an interface type that is not
	class-wide is not dispatching.

From-SVN: r213338
parent 7bfff488
2014-07-31 Robert Dewar <dewar@adacore.com> 2014-07-31 Robert Dewar <dewar@adacore.com>
* frontend.adb: Minor reformatting.
* sem.adb: Minor reformatting.
* sem_ch6.adb (Analyze_Null_Procedure): Set proper sloc for
identifiers on rewrite.
* par.adb: Minor comment updates.
* a-ngelfu.adb (Cos): Minor simplification.
* par-ch13.adb (Get_Aspect_Specifications): Improve messages
and recovery for bad aspect.
* exp_ch3.adb: Code clean up.
* sem_util.ads: Minor comment correction.
* sem_ch13.adb (Check_Array_Type): Properly handle large types.
* sem_ch3.adb: Code clean up.
* binderr.ads: Minor comment correction.
2014-07-31 Ed Schonberg <schonberg@adacore.com>
* exp_disp.adb (Expand_Interface_Conversion): A call whose
prefix is a static conversion to an interface type that is not
class-wide is not dispatching.
2014-07-31 Robert Dewar <dewar@adacore.com>
* inline.adb, s-traceb.adb, s-traceb-hpux.adb, memtrack.adb, * inline.adb, s-traceb.adb, s-traceb-hpux.adb, memtrack.adb,
s-traceb-mastop.adb: Minor reformatting. s-traceb-mastop.adb: Minor reformatting.
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2014, 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- --
...@@ -509,12 +509,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is ...@@ -509,12 +509,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is
function Cos (X : Float_Type'Base) return Float_Type'Base is function Cos (X : Float_Type'Base) return Float_Type'Base is
begin begin
if X = 0.0 then if abs X < Sqrt_Epsilon then
return 1.0;
elsif abs X < Sqrt_Epsilon then
return 1.0; return 1.0;
end if; end if;
return Float_Type'Base (Aux.Cos (Double (X))); return Float_Type'Base (Aux.Cos (Double (X)));
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2014, 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- --
...@@ -59,7 +59,7 @@ package Binderr is ...@@ -59,7 +59,7 @@ package Binderr is
-- specified by the File_Name_Type value stored in Error_Msg_File_2. -- specified by the File_Name_Type value stored in Error_Msg_File_2.
-- Insertion character $ (Dollar: insert unit name from Names table) -- Insertion character $ (Dollar: insert unit name from Names table)
-- The character & is replaced by the text for the unit name specified -- The character $ is replaced by the text for the unit name specified
-- by the Name_Id value stored in Error_Msg_Unit_1. The name is always -- by the Name_Id value stored in Error_Msg_Unit_1. The name is always
-- enclosed in quotes. A second $ may appear in a single message in -- enclosed in quotes. A second $ may appear in a single message in
-- which case it is similarly replaced by the name which is specified -- which case it is similarly replaced by the name which is specified
......
...@@ -4589,9 +4589,9 @@ package body Exp_Ch3 is ...@@ -4589,9 +4589,9 @@ package body Exp_Ch3 is
-- Expand_Record_Extension is called directly from the semantics, so -- Expand_Record_Extension is called directly from the semantics, so
-- we must check to see whether expansion is active before proceeding -- we must check to see whether expansion is active before proceeding
-- Because this affects the visibility of selected components in bodies -- Because this affects the visibility of selected components in bodies
-- of instances, it must also be called in ASIS mode. -- of instances.
if not (Expander_Active or ASIS_Mode) then if not Expander_Active then
return; return;
end if; end if;
......
...@@ -1191,6 +1191,19 @@ package body Exp_Disp is ...@@ -1191,6 +1191,19 @@ package body Exp_Disp is
end if; end if;
return; return;
-- A static conversion to an interface type that is not classwide is
-- curious but legal if the interface operation is a null procedure.
-- If the operation is abstract it will be rejected later.
elsif Is_Static
and then Is_Interface (Etype (N))
and then not Is_Class_Wide_Type (Etype (N))
and then Comes_From_Source (N)
then
Rewrite (N, Unchecked_Convert_To (Etype (N), N));
Analyze (N);
return;
end if; end if;
if not Is_Static then if not Is_Static then
......
...@@ -147,10 +147,10 @@ begin ...@@ -147,10 +147,10 @@ begin
Temp_File : Boolean; Temp_File : Boolean;
begin begin
-- We always analyze config files with style checks off, since -- We always analyze config files with style checks off, since we
-- we don't want a miscellaneous gnat.adc that is around to -- don't want a miscellaneous gnat.adc that is around to discombobulate
-- discombobulate intended -gnatg or -gnaty compilations. We -- intended -gnatg or -gnaty compilations. We also disconnect checking
-- also disconnect checking for maximum line length. -- for maximum line length.
Opt.Style_Check := False; Opt.Style_Check := False;
Style_Check := False; Style_Check := False;
......
...@@ -197,7 +197,7 @@ package body Ch13 is ...@@ -197,7 +197,7 @@ package body Ch13 is
-- The aspect mark is not recognized -- The aspect mark is not recognized
if A_Id = No_Aspect then if A_Id = No_Aspect then
Error_Msg_SC ("aspect identifier expected"); Error_Msg_N ("& is not a valid aspect identifier", Token_Node);
OK := False; OK := False;
-- Check bad spelling -- Check bad spelling
...@@ -205,8 +205,8 @@ package body Ch13 is ...@@ -205,8 +205,8 @@ package body Ch13 is
for J in Aspect_Id_Exclude_No_Aspect loop for J in Aspect_Id_Exclude_No_Aspect loop
if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J)) then if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J)) then
Error_Msg_Name_1 := Aspect_Names (J); Error_Msg_Name_1 := Aspect_Names (J);
Error_Msg_SC -- CODEFIX Error_Msg_N -- CODEFIX
("\possible misspelling of%"); ("\possible misspelling of%", Token_Node);
exit; exit;
end if; end if;
end loop; end loop;
...@@ -225,9 +225,13 @@ package body Ch13 is ...@@ -225,9 +225,13 @@ package body Ch13 is
Scan; -- past arrow Scan; -- past arrow
Set_Expression (Aspect, P_Expression); Set_Expression (Aspect, P_Expression);
-- The aspect may behave as a boolean aspect -- If we have a correct terminator (comma or semicolon, or a
-- reasonable likely missing comma), then just proceed.
elsif Token = Tok_Comma then elsif Token = Tok_Comma or else
Token = Tok_Semicolon or else
Token = Tok_Identifier
then
null; null;
-- Otherwise the aspect contains a junk definition -- Otherwise the aspect contains a junk definition
...@@ -480,6 +484,10 @@ package body Ch13 is ...@@ -480,6 +484,10 @@ package body Ch13 is
if OK then if OK then
Append (Aspect, Aspects); Append (Aspect, Aspects);
end if; end if;
end if;
-- Merge here after good or bad aspect (we should be at a comma
-- or a semicolon, but there might be other possible errors).
-- The aspect specification list contains more than one aspect -- The aspect specification list contains more than one aspect
...@@ -562,7 +570,6 @@ package body Ch13 is ...@@ -562,7 +570,6 @@ package body Ch13 is
<<Continue>> <<Continue>>
null; null;
end if;
end loop; end loop;
return Aspects; return Aspects;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2014, 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- --
...@@ -947,12 +947,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is ...@@ -947,12 +947,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- for aspects so it does not matter whether the aspect specifications -- for aspects so it does not matter whether the aspect specifications
-- are terminated by semicolon or some other character. -- are terminated by semicolon or some other character.
function Get_Aspect_Specifications
(Semicolon : Boolean := True) return List_Id;
-- Parse a list of aspects but do not attach them to a declaration node.
-- Subsidiary to the following procedure. Used when parsing a subprogram
-- specification that may be a declaration or a body.
procedure P_Aspect_Specifications procedure P_Aspect_Specifications
(Decl : Node_Id; (Decl : Node_Id;
Semicolon : Boolean := True); Semicolon : Boolean := True);
...@@ -977,6 +971,13 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is ...@@ -977,6 +971,13 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- are also ignored, but no error message is given (this is used when -- are also ignored, but no error message is given (this is used when
-- the caller has already taken care of the error message). -- the caller has already taken care of the error message).
function Get_Aspect_Specifications
(Semicolon : Boolean := True) return List_Id;
-- Parse a list of aspects but do not attach them to a declaration node.
-- Subsidiary to P_Aspect_Specifications procedure. Used when parsing
-- a subprogram specification that may be a declaration or a body.
-- Semicolon has the same meaning as for P_Aspect_Specifications above.
function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id; function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id;
-- Function to parse a code statement. The caller has scanned out -- Function to parse a code statement. The caller has scanned out
-- the name to be used as the subtype mark (but has not checked that -- the name to be used as the subtype mark (but has not checked that
......
...@@ -1268,7 +1268,6 @@ package body Sem is ...@@ -1268,7 +1268,6 @@ package body Sem is
Next => Suppress_Stack_Entries); Next => Suppress_Stack_Entries);
Suppress_Stack_Entries := Global_Suppress_Stack_Top; Suppress_Stack_Entries := Global_Suppress_Stack_Top;
return; return;
end Push_Global_Suppress_Stack_Entry; end Push_Global_Suppress_Stack_Entry;
------------------------------------- -------------------------------------
......
...@@ -12067,6 +12067,19 @@ package body Sem_Ch13 is ...@@ -12067,6 +12067,19 @@ package body Sem_Ch13 is
return; return;
end if; end if;
-- Case of component size is greater than or equal to 64 and the
-- alignment of the array is at least as large as the alignment
-- of the component. We are definitely OK in this situation.
if Known_Component_Size (Atyp)
and then Component_Size (Atyp) >= 64
and then Known_Alignment (Atyp)
and then Known_Alignment (Ctyp)
and then Alignment (Atyp) >= Alignment (Ctyp)
then
return;
end if;
-- Check actual component size -- Check actual component size
if not Known_Component_Size (Atyp) if not Known_Component_Size (Atyp)
......
...@@ -3503,6 +3503,7 @@ package body Sem_Ch3 is ...@@ -3503,6 +3503,7 @@ package body Sem_Ch3 is
and then Nkind (E) = N_Aggregate and then Nkind (E) = N_Aggregate
then then
Set_Etype (E, T); Set_Etype (E, T);
else else
Resolve (E, T); Resolve (E, T);
end if; end if;
...@@ -8407,9 +8408,16 @@ package body Sem_Ch3 is ...@@ -8407,9 +8408,16 @@ package body Sem_Ch3 is
elsif not Private_Extension then elsif not Private_Extension then
-- Add the _parent field in the derived type -- Add the _parent field in the derived type. In ASIS mode there is
-- not enough semantic information for full expansion, but set the
-- parent subtype to allow resolution of selected components in
-- instance bodies.
if ASIS_Mode then
Set_Parent_Subtype (Derived_Type, Parent_Type);
else
Expand_Record_Extension (Derived_Type, Type_Def); Expand_Record_Extension (Derived_Type, Type_Def);
end if;
-- Ada 2005 (AI-251): Addition of the Tag corresponding to all the -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
-- implemented interfaces if we are in expansion mode -- implemented interfaces if we are in expansion mode
......
...@@ -106,7 +106,7 @@ package body Sem_Ch6 is ...@@ -106,7 +106,7 @@ package body Sem_Ch6 is
procedure Analyze_Null_Procedure procedure Analyze_Null_Procedure
(N : Node_Id; (N : Node_Id;
Is_Completion : out Boolean); Is_Completion : out Boolean);
-- A null procedure can be a declaration or (Ada 2012) a completion. -- A null procedure can be a declaration or (Ada 2012) a completion
procedure Analyze_Return_Statement (N : Node_Id); procedure Analyze_Return_Statement (N : Node_Id);
-- Common processing for simple and extended return statements -- Common processing for simple and extended return statements
...@@ -1310,12 +1310,16 @@ package body Sem_Ch6 is ...@@ -1310,12 +1310,16 @@ package body Sem_Ch6 is
-- Create new entities for body and formals -- Create new entities for body and formals
Set_Defining_Unit_Name (Specification (Null_Body), Set_Defining_Unit_Name (Specification (Null_Body),
Make_Defining_Identifier (Loc, Chars (Defining_Entity (N)))); Make_Defining_Identifier
(Sloc (Defining_Entity (N)),
Chars (Defining_Entity (N))));
Form := First (Parameter_Specifications (Specification (Null_Body))); Form := First (Parameter_Specifications (Specification (Null_Body)));
while Present (Form) loop while Present (Form) loop
Set_Defining_Identifier (Form, Set_Defining_Identifier (Form,
Make_Defining_Identifier (Loc, Chars (Defining_Identifier (Form)))); Make_Defining_Identifier
(Sloc (Defining_Identifier (Form)),
Chars (Defining_Identifier (Form))));
Next (Form); Next (Form);
end loop; end loop;
......
...@@ -88,8 +88,8 @@ package Sem_Util is ...@@ -88,8 +88,8 @@ package Sem_Util is
function Addressable (V : Uint) return Boolean; function Addressable (V : Uint) return Boolean;
function Addressable (V : Int) return Boolean; function Addressable (V : Int) return Boolean;
pragma Inline (Addressable); pragma Inline (Addressable);
-- Returns True if the value of V is the word size of an addressable -- Returns True if the value of V is the word size or an addressable factor
-- factor of the word size (typically 8, 16, 32 or 64). -- of the word size (typically 8, 16, 32 or 64).
procedure Aggregate_Constraint_Checks procedure Aggregate_Constraint_Checks
(Exp : Node_Id; (Exp : Node_Id;
......
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