OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2014-08-04  Arnaud Charlet  <charlet@adacore.com>

	* exp_util.adb (Check_Float_Op_Overflow): No-op in codepeer
	mode for now, to revert to previous behavior.
	* checks.adb: Revert previous change, no longer needed.

2014-08-04  Robert Dewar  <dewar@adacore.com>

	* gnat1drv.adb (Adjust_Global_Switches): Don't set
	Check_Float_Overflow if Machine_Oveflows_On_Target is True.
	* sem_prag.adb (Analyze_Pragma, case Check_Float_Overflow): Don't
	set Check_Float_Overflow if Machine_Oveflows_On_Target is True.
	* switch-c.adb (Scan_Front_End_Switches): Don't set
	Check_Float_Overflow if Machine_Oveflows_On_Target is True.

2014-08-04  Vincent Celier  <celier@adacore.com>

	* prj-attr.adb: Add new default indications for
	attributes Object_Dir, Exec_Dir, Source_Dirs and Target.
	(Attribute_Default_Of): New function (Initialize): Set the
	default for those attributes that have one specified.
	* prj-attr.ads (Attribute_Data): New component Default.
	* prj-proc.adb (Expression): Take into account the new defaults
	for attributes Object_Dir, Exec_Dir and Source_Dirs.
	* prj-strt.adb (Attribute_Reference): Set the default for
	the attribute.
	* prj-tree.ads, prj-tree.adb (Default_Of): New function.
	(Set_Default_Of): New procedure.
	* prj.adb (The_Dot_String): New global Name_Id variable,
	initialized in procedure Initialize.
	(Dot_String): New function
	(Initialize): Initialize The_Dot_String.
	(Reset): Create the string list Shared.Dot_String_List.
	* prj.ads (Attribute_Default_Value): New enumeration type.
	(Project_Qualifier): Change enumeration value Dry to Abstract_Project.
	(Dot_String): New function.
	(Shared_Project_Tree_Data): New string list component Dot_String_List.
	* projects.texi: Document new defaults for attribute Object_Dir,
	Exec_Dir and Source_Dirs.

From-SVN: r213548
This commit is contained in:
Arnaud Charlet 2014-08-04 11:52:02 +02:00
parent e943fe8a6a
commit af6478c843
19 changed files with 347 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
gcc/ada/ChangeLog
View File

@ -1,3 +1,43 @@
2014-08-04 Arnaud Charlet <charlet@adacore.com>
* exp_util.adb (Check_Float_Op_Overflow): No-op in codepeer
mode for now, to revert to previous behavior.
* checks.adb: Revert previous change, no longer needed.
2014-08-04 Robert Dewar <dewar@adacore.com>
* gnat1drv.adb (Adjust_Global_Switches): Don't set
Check_Float_Overflow if Machine_Oveflows_On_Target is True.
* sem_prag.adb (Analyze_Pragma, case Check_Float_Overflow): Don't
set Check_Float_Overflow if Machine_Oveflows_On_Target is True.
* switch-c.adb (Scan_Front_End_Switches): Don't set
Check_Float_Overflow if Machine_Oveflows_On_Target is True.
2014-08-04 Vincent Celier <celier@adacore.com>
* prj-attr.adb: Add new default indications for
attributes Object_Dir, Exec_Dir, Source_Dirs and Target.
(Attribute_Default_Of): New function (Initialize): Set the
default for those attributes that have one specified.
* prj-attr.ads (Attribute_Data): New component Default.
* prj-proc.adb (Expression): Take into account the new defaults
for attributes Object_Dir, Exec_Dir and Source_Dirs.
* prj-strt.adb (Attribute_Reference): Set the default for
the attribute.
* prj-tree.ads, prj-tree.adb (Default_Of): New function.
(Set_Default_Of): New procedure.
* prj.adb (The_Dot_String): New global Name_Id variable,
initialized in procedure Initialize.
(Dot_String): New function
(Initialize): Initialize The_Dot_String.
(Reset): Create the string list Shared.Dot_String_List.
* prj.ads (Attribute_Default_Value): New enumeration type.
(Project_Qualifier): Change enumeration value Dry to Abstract_Project.
(Dot_String): New function.
(Shared_Project_Tree_Data): New string list component Dot_String_List.
* projects.texi: Document new defaults for attribute Object_Dir,
Exec_Dir and Source_Dirs.
2014-08-04 Robert Dewar <dewar@adacore.com>
* sem_ch12.adb: Minor reformatting.

13
gcc/ada/checks.adb
View File

@ -9214,7 +9214,6 @@ package body Checks is
Wnode : Node_Id := Warn_Node;
Ret_Result : Check_Result := (Empty, Empty);
Num_Checks : Integer := 0;
Reason : RT_Exception_Code := CE_Range_Check_Failed;
procedure Add_Check (N : Node_Id);
-- Adds the action given to Ret_Result if N is non-Empty
@ -9836,16 +9835,6 @@ package body Checks is
else
if not In_Subrange_Of (S_Typ, T_Typ) then
Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
-- Special case CodePeer_Mode and apparently redundant checks on
-- floating point types: these are used as overflow checks, see
-- Exp_Util.Check_Float_Op_Overflow.
elsif CodePeer_Mode and then Check_Float_Overflow
and then Is_Floating_Point_Type (S_Typ)
then
Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
Reason := CE_Overflow_Check_Failed;
end if;
end if;
end if;
@ -10040,7 +10029,7 @@ package body Checks is
Add_Check
(Make_Raise_Constraint_Error (Loc,
Condition => Cond,
Reason => Reason));
Reason => CE_Range_Check_Failed));
end if;
return Ret_Result;

26
gcc/ada/exp_util.adb
View File

@ -1643,32 +1643,14 @@ package body Exp_Util is
if not Check_Float_Overflow
or else not Is_Floating_Point_Type (Etype (N))
-- In CodePeer_Mode, rely on the overflow check flag being set instead
or else CodePeer_Mode
then
return;
end if;
-- Special expansion for CodePeer_Mode: we reuse the Apply_Range_Check
-- machinery instead of expanding a 'Valid attribute, since CodePeer
-- does not know how to handle expansion of 'Valid on floating point.
-- ??? Consider using the same expansion in normal mode. This should
-- work assuming division checks are also enabled (to prevent generation
-- of NaNs), except for e.g. unchecked conversions which might also
-- generate NaNs.
if CodePeer_Mode then
declare
Typ : constant Entity_Id := Etype (N);
begin
-- Prevent recursion
Set_Analyzed (N);
Apply_Range_Check (N, Typ);
Analyze_And_Resolve (N, Typ);
return;
end;
end if;
-- Otherwise we replace the expression by
-- do Tnn : constant ftype := expression;

6
gcc/ada/gnat1drv.adb
View File

@ -371,9 +371,11 @@ procedure Gnat1drv is
-- Detect overflow on unconstrained floating-point types, such as
-- the predefined types Float, Long_Float and Long_Long_Float from
-- package Standard.
-- package Standard. Not necessary if float overflows are checked
-- (Machine_Overflow true), since appropriate Do_Overflow_Check flags
-- will be set in any case.
Check_Float_Overflow := True;
Check_Float_Overflow := not Machine_Overflows_On_Target;
-- Set STRICT mode for overflow checks if not set explicitly. This
-- prevents suppressing of overflow checks by default, in code down

3
gcc/ada/prj-attr-pm.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2014, 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- --
@ -47,6 +47,7 @@ package body Prj.Attr.PM is
Attr_Kind => Unknown,
Read_Only => False,
Others_Allowed => False,
Default => Empty_Value,
Next =>
Package_Attributes.Table (To_Package.Value).First_Attribute));

73
gcc/ada/prj-attr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2014, 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- --
@ -34,7 +34,7 @@ package body Prj.Attr is
-- Data for predefined attributes and packages
-- Names are in lower case and end with '#'
-- Names are in lower case and end with '#' or 'D'.
-- Package names are preceded by 'P'
@ -59,6 +59,11 @@ package body Prj.Attr is
-- 'O' to indicate that others is allowed as an index for an associative
-- array
-- If the character after the name in lower case letter is a 'D'
-- (for default), then 'D' must be followed by an enumeration value of type
-- Attribute_Default_Value, followed by a '#'.
-- Example:
-- "SVobject_dirDdot_value#"
-- End is indicated by two consecutive '#'
Initialization_Data : constant String :=
@ -76,9 +81,9 @@ package body Prj.Attr is
-- Directories
"SVobject_dir#" &
"SVexec_dir#" &
"LVsource_dirs#" &
"SVobject_dirDdot_value#" &
"SVexec_dirDobject_dir_value#" &
"LVsource_dirsDdot_value#" &
"Lainherit_source_path#" &
"LVexcluded_source_dirs#" &
"LVignore_source_sub_dirs#" &
@ -129,7 +134,7 @@ package body Prj.Attr is
"Satoolchain_description#" &
"Saobject_generated#" &
"Saobjects_linked#" &
"SVtarget#" &
"SVtargetDtarget_value#" &
-- Configuration - Libraries
@ -416,6 +421,21 @@ package body Prj.Attr is
Package_Names (Last_Package_Name) := new String'(Name);
end Add_Package_Name;
--------------------------
-- Attribute_Default_Of --
--------------------------
function Attribute_Default_Of
(Attribute : Attribute_Node_Id) return Attribute_Default_Value
is
begin
if Attribute = Empty_Attribute then
return Empty_Value;
else
return Attrs.Table (Attribute.Value).Default;
end if;
end Attribute_Default_Of;
-----------------------
-- Attribute_Kind_Of --
-----------------------
@ -482,6 +502,7 @@ package body Prj.Attr is
First_Attribute : Attr_Node_Id := Attr.First_Attribute;
Read_Only : Boolean;
Others_Allowed : Boolean;
Default : Attribute_Default_Value;
function Attribute_Location return String;
-- Returns a string depending if we are in the project level attributes
@ -611,9 +632,11 @@ package body Prj.Attr is
Read_Only := False;
Others_Allowed := False;
Default := Empty_Value;
if Initialization_Data (Start) = 'R' then
Read_Only := True;
Default := Read_Only_Value;
Start := Start + 1;
elsif Initialization_Data (Start) = 'O' then
@ -623,12 +646,42 @@ package body Prj.Attr is
Finish := Start;
while Initialization_Data (Finish) /= '#' loop
while Initialization_Data (Finish) /= '#'
and then
Initialization_Data (Finish) /= 'D'
loop
Finish := Finish + 1;
end loop;
Attribute_Name :=
Name_Id_Of (Initialization_Data (Start .. Finish - 1));
if Initialization_Data (Finish) = 'D' then
Start := Finish + 1;
Finish := Start;
while Initialization_Data (Finish) /= '#' loop
Finish := Finish + 1;
end loop;
declare
Default_Name : constant String :=
Initialization_Data (Start .. Finish - 1);
pragma Unsuppress (All_Checks);
begin
Default := Attribute_Default_Value'Value (Default_Name);
exception
when Constraint_Error =>
Osint.Fail
("illegal default value """ &
Default_Name &
""" for attribute " &
Get_Name_String (Attribute_Name));
end;
end if;
Attrs.Increment_Last;
if Current_Attribute = Empty_Attr then
@ -662,6 +715,7 @@ package body Prj.Attr is
Attr_Kind => Attr_Kind,
Read_Only => Read_Only,
Others_Allowed => Others_Allowed,
Default => Default,
Next => Empty_Attr);
Start := Finish + 1;
end if;
@ -770,7 +824,8 @@ package body Prj.Attr is
Attr_Kind : Defined_Attribute_Kind;
Var_Kind : Defined_Variable_Kind;
Index_Is_File_Name : Boolean := False;
Opt_Index : Boolean := False)
Opt_Index : Boolean := False;
Default : Attribute_Default_Value := Empty_Value)
is
Attr_Name : Name_Id;
First_Attr : Attr_Node_Id := Empty_Attr;
@ -840,6 +895,7 @@ package body Prj.Attr is
Attr_Kind => Real_Attr_Kind,
Read_Only => False,
Others_Allowed => False,
Default => Default,
Next => First_Attr);
Package_Attributes.Table (In_Package.Value).First_Attribute :=
@ -952,6 +1008,7 @@ package body Prj.Attr is
Attr_Kind => Attr_Kind,
Read_Only => False,
Others_Allowed => False,
Default => Attributes (Index).Default,
Next => First_Attr);
First_Attr := Attrs.Last;
end loop;

18
gcc/ada/prj-attr.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2014, 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- --
@ -107,6 +107,10 @@ package Prj.Attr is
Var_Kind : Defined_Variable_Kind;
-- The attribute value kind: single or list
Default : Attribute_Default_Value := Empty_Value;
-- The value of the attribute when referenced if the attribute has not
-- been (yet) declared.
end record;
-- Name and characteristics of an attribute in a package registered
-- explicitly with Register_New_Package (see below).
@ -190,6 +194,12 @@ package Prj.Attr is
-- Set the variable kind of a known attribute. Does nothing if Attribute is
-- Empty_Attribute.
function Attribute_Default_Of
(Attribute : Attribute_Node_Id) return Attribute_Default_Value;
-- Returns the default of the attribute, Read_Only_Value for read only
-- attributes, Empty_Value when ndefault not specified or specified
-- value.
function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean;
-- Returns True if Attribute is a known attribute and may have an
-- optional index. Returns False otherwise.
@ -232,12 +242,13 @@ package Prj.Attr is
Attr_Kind : Defined_Attribute_Kind;
Var_Kind : Defined_Variable_Kind;
Index_Is_File_Name : Boolean := False;
Opt_Index : Boolean := False);
Opt_Index : Boolean := False;
Default : Attribute_Default_Value := Empty_Value);
-- Add a new attribute to registered package In_Package. Fails if Name
-- (the attribute name) is empty, if In_Package is Empty_Package or if
-- the attribute name has a duplicate name. See definition of type
-- Attribute_Data above for the meaning of parameters Attr_Kind, Var_Kind,
-- Index_Is_File_Name and Opt_Index.
-- Index_Is_File_Name, Opt_Index and Default.
function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id;
-- Returns the package node id of the package with name Name. Returns
@ -320,6 +331,7 @@ private
Attr_Kind : Attribute_Kind;
Read_Only : Boolean;
Others_Allowed : Boolean;
Default : Attribute_Default_Value;
Next : Attr_Node_Id;
end record;
-- Data for an attribute

2
gcc/ada/prj-nmsc.adb
View File

@ -8517,7 +8517,7 @@ package body Prj.Nmsc is
Show_Source_Dirs (Project, Shared);
end if;
if Project.Qualifier = Dry then
if Project.Qualifier = Abstract_Project then
Check_Abstract_Project (Project, Data);
end if;
end case;

21
gcc/ada/prj-part.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2014, 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- --
@ -1094,7 +1094,8 @@ package body Prj.Part is
while Present (With_Clause) loop
Imported := Project_Node_Of (With_Clause, In_Tree);
if Project_Qualifier_Of (Imported, In_Tree) /= Dry then
if Project_Qualifier_Of (Imported, In_Tree) /= Abstract_Project
then
Error_Msg_Name_1 := Name_Id (Path_Name_Of (Imported, In_Tree));
Error_Msg (Flags, "can only import abstract projects, not %%",
Token_Ptr);
@ -1152,7 +1153,7 @@ package body Prj.Part is
Qualifier_Location := Token_Ptr;
if Token = Tok_Abstract then
Proj_Qualifier := Dry;
Proj_Qualifier := Abstract_Project;
Scan (In_Tree);
elsif Token = Tok_Identifier then
@ -1370,7 +1371,8 @@ package body Prj.Part is
if Extended then
if A_Project_Name_And_Node.Extended then
if A_Project_Name_And_Node.Proj_Qualifier /= Dry then
if A_Project_Name_And_Node.Proj_Qualifier /= Abstract_Project
then
Error_Msg
(Env.Flags,
"cannot extend the same project file several times",
@ -1811,8 +1813,11 @@ package body Prj.Part is
-- with sources if it inherits sources from the project
-- it extends.
if Project_Qualifier_Of (Project, In_Tree) = Dry and then
Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry
if Project_Qualifier_Of
(Project, In_Tree) = Abstract_Project
and then
Project_Qualifier_Of
(Extended_Project, In_Tree) /= Abstract_Project
then
Error_Msg
(Env.Flags, "an abstract project can only extend " &
@ -1925,7 +1930,9 @@ package body Prj.Part is
Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration);
if Present (Extended_Project)
and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry
and then
Project_Qualifier_Of
(Extended_Project, In_Tree) /= Abstract_Project
then
Set_Extending_Project_Of
(Project_Declaration_Of (Extended_Project, In_Tree), In_Tree,

2
gcc/ada/prj-pp.adb
View File

@ -403,7 +403,7 @@ package body Prj.PP is
Write_String ("library ", Indent);
when Configuration =>
Write_String ("configuration ", Indent);
when Dry =>
when Abstract_Project =>
Write_String ("abstract ", Indent);
end case;

82
gcc/ada/prj-proc.adb
View File

@ -519,6 +519,8 @@ package body Prj.Proc is
Last : String_List_Id := Nil_String;
-- Reference to the last string elements in Result, when Kind is List
Current_Term_Kind : Project_Node_Kind;
begin
Result.Project := Project;
Result.Location := Location_Of (First_Term, From_Project_Node_Tree);
@ -528,8 +530,10 @@ package body Prj.Proc is
The_Term := First_Term;
while Present (The_Term) loop
The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree);
Current_Term_Kind :=
Kind_Of (The_Current_Term, From_Project_Node_Tree);
case Kind_Of (The_Current_Term, From_Project_Node_Tree) is
case Current_Term_Kind is
when N_Literal_String =>
@ -700,6 +704,13 @@ package body Prj.Proc is
Index : Name_Id := No_Name;
begin
<<Object_Dir_Restart>>
The_Project := Project;
The_Package := Pkg;
The_Name := No_Name;
The_Variable_Id := No_Variable;
Index := No_Name;
if Present (Term_Project)
and then Term_Project /= From_Project_Node
then
@ -741,9 +752,7 @@ package body Prj.Proc is
The_Name :=
Name_Of (The_Current_Term, From_Project_Node_Tree);
if Kind_Of (The_Current_Term, From_Project_Node_Tree) =
N_Attribute_Reference
then
if Current_Term_Kind = N_Attribute_Reference then
Index :=
Associative_Array_Index_Of
(The_Current_Term, From_Project_Node_Tree);
@ -759,9 +768,7 @@ package body Prj.Proc is
-- First, if there is a package, look into the package
if Kind_Of (The_Current_Term, From_Project_Node_Tree) =
N_Variable_Reference
then
if Current_Term_Kind = N_Variable_Reference then
The_Variable_Id :=
Shared.Packages.Table
(The_Package).Decl.Variables;
@ -786,9 +793,7 @@ package body Prj.Proc is
-- If we have not found it, look into the project
if Kind_Of (The_Current_Term, From_Project_Node_Tree) =
N_Variable_Reference
then
if Current_Term_Kind = N_Variable_Reference then
The_Variable_Id := The_Project.Decl.Variables;
else
The_Variable_Id := The_Project.Decl.Attributes;
@ -882,6 +887,63 @@ package body Prj.Proc is
end;
end if;
-- Check the defaults
if Current_Term_Kind = N_Attribute_Reference
and then The_Variable.Default
then
declare
The_Default : constant Attribute_Default_Value :=
Default_Of
(The_Current_Term, From_Project_Node_Tree);
begin
case The_Variable.Kind is
when Undefined =>
null;
when Single =>
case The_Default is
when Read_Only_Value =>
null;
when Empty_Value =>
The_Variable.Value := Empty_String;
when Dot_Value =>
The_Variable.Value := Dot_String;
when Object_Dir_Value =>
From_Project_Node_Tree.Project_Nodes.Table
(The_Current_Term).Name :=
Snames.Name_Object_Dir;
From_Project_Node_Tree.Project_Nodes.Table
(The_Current_Term).Default :=
Dot_Value;
goto Object_Dir_Restart;
when Target_Value =>
null;
end case;
when List =>
case The_Default is
when Read_Only_Value =>
null;
when Empty_Value =>
The_Variable.Values := Nil_String;
when Dot_Value =>
The_Variable.Values :=
Shared.Dot_String_List;
when Object_Dir_Value | Target_Value =>
null;
end case;
end case;
end;
end if;
case Kind is
when Undefined =>

3
gcc/ada/prj-strt.adb
View File

@ -218,6 +218,9 @@ package body Prj.Strt is
(Reference, In_Tree,
To => Attribute_Kind_Of (Current_Attribute) in
All_Case_Insensitive_Associative_Array);
Set_Default_Of
(Reference, In_Tree,
To => Attribute_Default_Of (Current_Attribute));
-- Scan past the attribute name

39
gcc/ada/prj-tree.adb
View File

@ -122,6 +122,7 @@ package body Prj.Tree is
Src_Index => 0,
Path_Name => No_Path,
Value => No_Name,
Default => Empty_Value,
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
@ -172,6 +173,7 @@ package body Prj.Tree is
Src_Index => 0,
Path_Name => No_Path,
Value => Comments.Table (J).Value,
Default => Empty_Value,
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
@ -340,6 +342,7 @@ package body Prj.Tree is
Src_Index => 0,
Path_Name => No_Path,
Value => No_Name,
Default => Empty_Value,
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
@ -385,6 +388,22 @@ package body Prj.Tree is
return In_Tree.Project_Nodes.Table (Node).Field1;
end Current_Term;
----------------
-- Default_Of --
----------------
function Default_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Attribute_Default_Value
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference);
return In_Tree.Project_Nodes.Table (Node).Default;
end Default_Of;
--------------------------
-- Default_Project_Node --
--------------------------
@ -416,6 +435,7 @@ package body Prj.Tree is
Src_Index => 0,
Path_Name => No_Path,
Value => No_Name,
Default => Empty_Value,
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
@ -452,6 +472,7 @@ package body Prj.Tree is
Src_Index => 0,
Path_Name => No_Path,
Value => No_Name,
Default => Empty_Value,
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
@ -486,6 +507,7 @@ package body Prj.Tree is
Src_Index => 0,
Path_Name => No_Path,
Value => Comments.Table (J).Value,
Default => Empty_Value,
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
@ -1867,6 +1889,23 @@ package body Prj.Tree is
In_Tree.Project_Nodes.Table (Node).Field1 := To;
end Set_Current_Term;
--------------------
-- Set_Default_Of --
--------------------
procedure Set_Default_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Attribute_Default_Value)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference);
In_Tree.Project_Nodes.Table (Node).Default := To;
end Set_Default_Of;
----------------------
-- Set_Directory_Of --
----------------------

20
gcc/ada/prj-tree.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2014, 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- --
@ -590,6 +590,12 @@ package Prj.Tree is
-- Only valid for N_Variable_Reference or N_Attribute_Reference nodes.
-- May return Empty_Node.
function Default_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Attribute_Default_Value;
pragma Inline (Default_Of);
-- Only valid for N_Attribute_Reference nodes
function String_Type_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
@ -1068,7 +1074,14 @@ package Prj.Tree is
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Package_Node_Of);
-- Only valid for N_Variable_Reference or N_Attribute_Reference nodes.
-- Only valid for N_Variable_Reference or N_Attribute_Reference nodes
procedure Set_Default_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Attribute_Default_Value);
pragma Inline (Set_Default_Of);
-- Only valid for N_Attribute_Reference nodes
procedure Set_String_Type_Of
(Node : Project_Node_Id;
@ -1179,6 +1192,9 @@ package Prj.Tree is
Value : Name_Id := No_Name;
-- See below for what Project_Node_Kind it is used
Default : Attribute_Default_Value := Empty_Value;
-- Only used in N_Attribute_Reference
Field1 : Project_Node_Id := Empty_Node;
-- See below the meaning for each Project_Node_Kind

29
gcc/ada/prj.adb
View File

@ -61,6 +61,8 @@ package body Prj is
The_Empty_String : Name_Id := No_Name;
The_Dot_String : Name_Id := No_Name;
Debug_Level : Integer := 0;
-- Current indentation level for debug traces
@ -307,6 +309,15 @@ package body Prj is
end case;
end Dependency_Name;
----------------
-- Dot_String --
----------------
function Dot_String return Name_Id is
begin
return The_Dot_String;
end Dot_String;
----------------
-- Empty_File --
----------------
@ -1057,6 +1068,10 @@ package body Prj is
Name_Len := 0;
The_Empty_String := Name_Find;
Name_Len := 1;
Name_Buffer (1) := '.';
The_Dot_String := Name_Find;
Prj.Attr.Initialize;
-- Make sure that new reserved words after Ada 95 may be used as
@ -1442,6 +1457,20 @@ package body Prj is
Array_Table.Init (Tree.Shared.Arrays);
Package_Table.Init (Tree.Shared.Packages);
-- Create Dot_String_List
String_Element_Table.Append
(Tree.Shared.String_Elements,
String_Element'
(Value => The_Dot_String,
Index => 0,
Display_Value => The_Dot_String,
Location => No_Location,
Flag => False,
Next => Nil_String));
Tree.Shared.Dot_String_List :=
String_Element_Table.Last (Tree.Shared.String_Elements);
-- Private part table
Temp_Files_Table.Init (Tree.Shared.Private_Part.Temp_Files);

27
gcc/ada/prj.ads
View File

@ -72,6 +72,25 @@ package Prj is
type Yes_No_Unknown is (Yes, No, Unknown);
-- Tri-state to decide if -lgnarl is needed when linking
type Attribute_Default_Value is
(Read_Only_Value,
-- for read only attributes (Name, Project_Dir)
Empty_Value,
-- empty string or empty string list
Dot_Value,
-- "." or (".")
Object_Dir_Value,
-- 'Object_Dir
Target_Value
-- 'Target (special rules)
);
-- Describe the default values of attributes that are referenced but not
-- declared.
pragma Warnings (Off);
type Project_Qualifier is
(Unspecified,
@ -83,7 +102,7 @@ package Prj is
Library,
Configuration,
Dry,
Abstract_Project,
Aggregate,
Aggregate_Library);
pragma Warnings (On);
@ -91,7 +110,7 @@ package Prj is
-- file:
-- Standard: standard project ...
-- Library: library project is ...
-- Dry: abstract project is
-- Abstract_Project: abstract project is
-- Aggregate: aggregate project is
-- Aggregate_Library: aggregate library project is ...
-- Configuration: configuration project is ...
@ -123,6 +142,9 @@ package Prj is
function Empty_String return Name_Id;
-- Return the id for an empty string ""
function Dot_String return Name_Id;
-- Return the id for "."
type Path_Information is record
Name : Path_Name_Type := No_Path;
Display_Name : Path_Name_Type := No_Path;
@ -1570,6 +1592,7 @@ package Prj is
Arrays : Array_Table.Instance;
Packages : Package_Table.Instance;
Private_Part : Private_Project_Tree_Data;
Dot_String_List : String_List_Id := Nil_String;
end record;
type Shared_Project_Tree_Data_Access is access all Shared_Project_Tree_Data;
-- The data that is shared among multiple trees, when these trees are

11
gcc/ada/projects.texi
View File

@ -3724,7 +3724,7 @@ Here are some examples of attribute declarations:
Attributes references may appear anywhere in expressions, and are used
to retrieve the value previously assigned to the attribute. If an attribute
has not been set in a given package or project, its value defaults to the
empty string or the empty list.
empty string or the empty list, with some exceptions.
@smallexample
attribute_reference ::=
@ -3746,6 +3746,15 @@ Examples are:
Builder'Default_Switches ("Ada")
@end smallexample
The exceptions to the empty defaults are:
@itemize @bullet
@item Object_Dir: default is "."
@item Exec_Dir: default is 'Object_Dir, that is the value of attribute
Object_Dir in the same project, declared or defaulted.
@item Source_Dirs: default is (".")
@end itemize
@noindent
The prefix of an attribute may be:

2
gcc/ada/sem_prag.adb
View File

@ -11806,7 +11806,7 @@ package body Sem_Prag is
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
Check_Arg_Count (0);
Check_Float_Overflow := True;
Check_Float_Overflow := not Machine_Overflows_On_Target;
----------------
-- Check_Name --

4
gcc/ada/switch-c.adb
View File

@ -32,11 +32,13 @@ with Lib; use Lib;
with Osint; use Osint;
with Opt; use Opt;
with Stylesw; use Stylesw;
with Targparm; use Targparm;
with Ttypes; use Ttypes;
with Validsw; use Validsw;
with Warnsw; use Warnsw;
with Ada.Unchecked_Deallocation;
with System.WCh_Con; use System.WCh_Con;
with System.OS_Lib;
@ -572,7 +574,7 @@ package body Switch.C is
when 'F' =>
Ptr := Ptr + 1;
Check_Float_Overflow := True;
Check_Float_Overflow := not Machine_Overflows_On_Target;
-- -gnateG (save preprocessor output)