Commit 23c4ff9b by Arnaud Charlet

[multiple changes]

2009-07-13  Emmanuel Briot  <briot@adacore.com>

	* prj-env.adb (Create_Config_Pragmas_File): Iterate on sources rather
	than units.

2009-07-13  Thomas Quinot  <quinot@adacore.com>

	* sem_ch3.adb (Process_Full_View): Propagate Has_Specified_Stream_{Read,
	Write,Input,Output} from private view to full view.

	* sem_type.adb, sem_type.ads: Minor reformatting

2009-07-13  Nicolas Setton  <setton@adacore.com>

	* exp_dbug.ads: Add documentation note on the utility of
	DW_AT_GNAT_encoding for IDEs.

2009-07-13  Robert Dewar  <dewar@adacore.com>

	* g-socthi-vxworks.adb: Minor reformatting

	* gnatcmd.adb: Minor reformatting

From-SVN: r149561
parent 72a3d7c7
2009-07-13 Emmanuel Briot <briot@adacore.com>
* prj-env.adb (Create_Config_Pragmas_File): Iterate on sources rather
than units.
2009-07-13 Thomas Quinot <quinot@adacore.com>
* sem_ch3.adb (Process_Full_View): Propagate Has_Specified_Stream_{Read,
Write,Input,Output} from private view to full view.
* sem_type.adb, sem_type.ads: Minor reformatting
2009-07-13 Nicolas Setton <setton@adacore.com>
* exp_dbug.ads: Add documentation note on the utility of
DW_AT_GNAT_encoding for IDEs.
2009-07-13 Robert Dewar <dewar@adacore.com>
* g-socthi-vxworks.adb: Minor reformatting
* gnatcmd.adb: Minor reformatting
2009-07-13 Thomas Quinot <quinot@adacore.com> 2009-07-13 Thomas Quinot <quinot@adacore.com>
* rtsfind.ads, exp_dist.adb (RE_Allocate_Buffer): Runtime entry * rtsfind.ads, exp_dist.adb (RE_Allocate_Buffer): Runtime entry
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- -- Copyright (C) 1996-2009, 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- --
...@@ -1522,33 +1522,38 @@ package Exp_Dbug is ...@@ -1522,33 +1522,38 @@ package Exp_Dbug is
-- to DWARF2/3 are generated, with the following variations from the above -- to DWARF2/3 are generated, with the following variations from the above
-- specification. -- specification.
-- Change in the contents of the DW_AT_name attribute. -- Change in the contents of the DW_AT_name attribute
-- The operators are represented in their natural form. (Ie, the addition
-- operator is written as "+" instead of "Oadd").
-- The component separation string is "." instead of "__"
-- Introduction of DW_AT_GNAT_encoding, encoded with value 0x2301. -- The operators are represented in their natural form. (for example,
-- Any debugging information entry representing a program entity, named -- the addition operator is written as "+" instead of "Oadd"). The
-- or implicit, may have a DW_AT_GNAT_encoding attribute. The value of -- component separator is "." instead of "__"
-- this attribute is a string representing the suffix internally added
-- by GNAT for various purposes, mainly for representing debug
-- information compatible with other formats.
-- If a debugging information entry has multiple encodings, all of them -- Introduction of DW_AT_GNAT_encoding, encoded with value 0x2301
-- will be listed in DW_AT_GNAT_encoding. The separator for this list
-- is ':'. -- Any debugging information entry representing a program entity, named
-- or implicit, may have a DW_AT_GNAT_encoding attribute. The value of
-- this attribute is a string representing the suffix internally added
-- by GNAT for various purposes, mainly for representing debug
-- information compatible with other formats. In particular this is
-- useful for IDEs which need to filter out information internal to
-- GNAT from their graphical interfaces.
-- If a debugging information entry has multiple encodings, all of them
-- will be listed in DW_AT_GNAT_encoding using the list separator ':'.
-- Introduction of DW_AT_GNAT_descriptive_type, encoded with value 0x2302 -- Introduction of DW_AT_GNAT_descriptive_type, encoded with value 0x2302
-- Any debugging information entry representing a type may have a
-- DW_AT_GNAT_descriptive_type attribute whose value is a reference, -- Any debugging information entry representing a type may have a
-- pointing to a debugging information entry representing another type -- DW_AT_GNAT_descriptive_type attribute whose value is a reference,
-- associated to the type. -- pointing to a debugging information entry representing another type
-- associated to the type.
-- Modification of the contents of the DW_AT_producer string.
-- When emitting full GNAT Vendor extensions to DWARF2/3, "-gdwarf+" -- Modification of the contents of the DW_AT_producer string
-- is appended to the DW_AT_producer string.
-- When emitting full GNAT Vendor extensions to DWARF2/3, "-gdwarf+"
-- is appended to the DW_AT_producer string.
-- --
-- When emitting only DW_AT_GNAT_descriptive_type, "-gdwarf+-" is -- When emitting only DW_AT_GNAT_descriptive_type, "-gdwarf+-" is
-- appended to the DW_AT_producer string. -- appended to the DW_AT_producer string.
end Exp_Dbug; end Exp_Dbug;
...@@ -369,12 +369,15 @@ package body GNAT.Sockets.Thin is ...@@ -369,12 +369,15 @@ package body GNAT.Sockets.Thin is
begin begin
loop loop
if To = Null_Address then if To = Null_Address then
-- In violation of the standard sockets API, VxWorks does not -- In violation of the standard sockets API, VxWorks does not
-- support sendto(2) calls on connected sockets with a null -- support sendto(2) calls on connected sockets with a null
-- destination address, so use send(2) instead in that case. -- destination address, so use send(2) instead in that case.
Res := Syscall_Send (S, Msg, Len, Flags); Res := Syscall_Send (S, Msg, Len, Flags);
-- Normal case where destination address is non-null
else else
Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
end if; end if;
......
...@@ -364,7 +364,7 @@ procedure GNATCmd is ...@@ -364,7 +364,7 @@ procedure GNATCmd is
File := File :=
new String' new String'
(Get_Name_String (Get_Name_String
(Proj.Project.Object_Directory.Name) & (Proj.Project.Object_Directory.Name) &
B_Start.all & B_Start.all &
MLib.Fil.Ext_To MLib.Fil.Ext_To
(Get_Name_String (Get_Name_String
...@@ -390,7 +390,7 @@ procedure GNATCmd is ...@@ -390,7 +390,7 @@ procedure GNATCmd is
File := File :=
new String' new String'
(Get_Name_String (Get_Name_String
(Proj.Project.Object_Directory.Name) & (Proj.Project.Object_Directory.Name) &
B_Start.all & B_Start.all &
Get_Name_String (Proj.Project.Library_Name) & Get_Name_String (Proj.Project.Library_Name) &
".ci"); ".ci");
...@@ -1080,9 +1080,7 @@ procedure GNATCmd is ...@@ -1080,9 +1080,7 @@ procedure GNATCmd is
-- replace the file with the absolute path. -- replace the file with the absolute path.
Last_Switches.Table (J) := Last_Switches.Table (J) :=
new String' new String'(Dir & ALI_File (1 .. Last));
(Dir
& ALI_File (1 .. Last));
-- And we are done -- And we are done
......
...@@ -401,9 +401,9 @@ package body Prj.Env is ...@@ -401,9 +401,9 @@ package body Prj.Env is
File_Name : Path_Name_Type := No_Path; File_Name : Path_Name_Type := No_Path;
File : File_Descriptor := Invalid_FD; File : File_Descriptor := Invalid_FD;
Current_Unit : Unit_Index := Units_Htable.Get_First (In_Tree.Units_HT);
Current_Naming : Naming_Id; Current_Naming : Naming_Id;
Iter : Source_Iterator;
Source : Source_Id;
Status : Boolean; Status : Boolean;
-- For call to Close -- For call to Close
...@@ -418,11 +418,7 @@ package body Prj.Env is ...@@ -418,11 +418,7 @@ package body Prj.Env is
-- If not, create one, and put its name in the project data, -- If not, create one, and put its name in the project data,
-- with the indication that it is a temporary file. -- with the indication that it is a temporary file.
procedure Put procedure Put (Source : Source_Id);
(Unit_Name : Name_Id;
File_Name : File_Name_Type;
Unit_Kind : Spec_Or_Body;
Index : Int);
-- Put an SFN pragma in the temporary file -- Put an SFN pragma in the temporary file
procedure Put (File : File_Descriptor; S : String); procedure Put (File : File_Descriptor; S : String);
...@@ -449,7 +445,7 @@ package body Prj.Env is ...@@ -449,7 +445,7 @@ package body Prj.Env is
if Lang = null then if Lang = null then
if Current_Verbosity = High then if Current_Verbosity = High then
Write_Str ("Languages does not contain Ada, nothing to do"); Write_Line (" Languages does not contain Ada, nothing to do");
end if; end if;
return; return;
...@@ -559,12 +555,7 @@ package body Prj.Env is ...@@ -559,12 +555,7 @@ package body Prj.Env is
-- Put -- -- Put --
--------- ---------
procedure Put procedure Put (Source : Source_Id) is
(Unit_Name : Name_Id;
File_Name : File_Name_Type;
Unit_Kind : Spec_Or_Body;
Index : Int)
is
begin begin
-- A temporary file needs to be open -- A temporary file needs to be open
...@@ -573,20 +564,20 @@ package body Prj.Env is ...@@ -573,20 +564,20 @@ package body Prj.Env is
-- Put the pragma SFN for the unit kind (spec or body) -- Put the pragma SFN for the unit kind (spec or body)
Put (File, "pragma Source_File_Name_Project ("); Put (File, "pragma Source_File_Name_Project (");
Put (File, Namet.Get_Name_String (Unit_Name)); Put (File, Namet.Get_Name_String (Source.Unit.Name));
if Unit_Kind = Spec then if Source.Kind = Spec then
Put (File, ", Spec_File_Name => """); Put (File, ", Spec_File_Name => """);
else else
Put (File, ", Body_File_Name => """); Put (File, ", Body_File_Name => """);
end if; end if;
Put (File, Namet.Get_Name_String (File_Name)); Put (File, Namet.Get_Name_String (Source.File));
Put (File, """"); Put (File, """");
if Index /= 0 then if Source.Index /= 0 then
Put (File, ", Index =>"); Put (File, ", Index =>");
Put (File, Index'Img); Put (File, Source.Index'Img);
end if; end if;
Put_Line (File, ");"); Put_Line (File, ");");
...@@ -652,30 +643,21 @@ package body Prj.Env is ...@@ -652,30 +643,21 @@ package body Prj.Env is
Check_Imported_Projects (For_Project, Dummy, Imported_First => False); Check_Imported_Projects (For_Project, Dummy, Imported_First => False);
-- Visit all the units and process those that need an SFN pragma -- Visit all the files and process those that need an SFN pragma
while Current_Unit /= No_Unit_Index loop Iter := For_Each_Source (In_Tree, For_Project);
if Current_Unit.File_Names (Spec) /= null
and then Current_Unit.File_Names (Spec).Naming_Exception
and then not Current_Unit.File_Names (Spec).Locally_Removed
then
Put (Current_Unit.Name,
Current_Unit.File_Names (Spec).File,
Spec,
Current_Unit.File_Names (Spec).Index);
end if;
if Current_Unit.File_Names (Impl) /= null while Element (Iter) /= No_Source loop
and then Current_Unit.File_Names (Impl).Naming_Exception Source := Element (Iter);
and then not Current_Unit.File_Names (Impl).Locally_Removed
if Source.Index >= 1
and then not Source.Locally_Removed
and then Source.Unit /= null
then then
Put (Current_Unit.Name, Put (Source);
Current_Unit.File_Names (Impl).File,
Impl,
Current_Unit.File_Names (Impl).Index);
end if; end if;
Current_Unit := Units_Htable.Get_Next (In_Tree.Units_HT); Next (Iter);
end loop; end loop;
-- If there are no non standard naming scheme, issue the GNAT -- If there are no non standard naming scheme, issue the GNAT
......
...@@ -7905,7 +7905,7 @@ package body Sem_Ch3 is ...@@ -7905,7 +7905,7 @@ package body Sem_Ch3 is
-- declaration, all clauses are inherited. -- declaration, all clauses are inherited.
if No (First_Rep_Item (Def_Id)) then if No (First_Rep_Item (Def_Id)) then
Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
end if; end if;
if Is_Tagged_Type (T) then if Is_Tagged_Type (T) then
...@@ -16443,6 +16443,22 @@ package body Sem_Ch3 is ...@@ -16443,6 +16443,22 @@ package body Sem_Ch3 is
Set_Is_CPP_Class (Full_T); Set_Is_CPP_Class (Full_T);
Set_Convention (Full_T, Convention_CPP); Set_Convention (Full_T, Convention_CPP);
end if; end if;
-- If the private view has user specified stream attributes, then so has
-- the full view.
if Has_Specified_Stream_Read (Priv_T) then
Set_Has_Specified_Stream_Read (Full_T);
end if;
if Has_Specified_Stream_Write (Priv_T) then
Set_Has_Specified_Stream_Write (Full_T);
end if;
if Has_Specified_Stream_Input (Priv_T) then
Set_Has_Specified_Stream_Input (Full_T);
end if;
if Has_Specified_Stream_Output (Priv_T) then
Set_Has_Specified_Stream_Output (Full_T);
end if;
end Process_Full_View; end Process_Full_View;
----------------------------------- -----------------------------------
......
...@@ -1204,9 +1204,9 @@ package body Sem_Type is ...@@ -1204,9 +1204,9 @@ package body Sem_Type is
-- for special handling of expressions with universal operands, see -- for special handling of expressions with universal operands, see
-- comments to Has_Abstract_Interpretation below. -- comments to Has_Abstract_Interpretation below.
------------------------ -----------------------
-- In_Generic_Actual -- -- In_Generic_Actual --
------------------------ -----------------------
function In_Generic_Actual (Exp : Node_Id) return Boolean is function In_Generic_Actual (Exp : Node_Id) return Boolean is
Par : constant Node_Id := Parent (Exp); Par : constant Node_Id := Parent (Exp);
...@@ -2147,9 +2147,8 @@ package body Sem_Type is ...@@ -2147,9 +2147,8 @@ package body Sem_Type is
------------------------- -------------------------
function Has_Compatible_Type function Has_Compatible_Type
(N : Node_Id; (N : Node_Id;
Typ : Entity_Id) Typ : Entity_Id) return Boolean
return Boolean
is is
I : Interp_Index; I : Interp_Index;
It : Interp; It : Interp;
...@@ -2597,9 +2596,8 @@ package body Sem_Type is ...@@ -2597,9 +2596,8 @@ package body Sem_Type is
--------------------------- ---------------------------
function Is_Invisible_Operator function Is_Invisible_Operator
(N : Node_Id; (N : Node_Id;
T : Entity_Id) T : Entity_Id) return Boolean
return Boolean
is is
Orig_Node : constant Node_Id := Original_Node (N); Orig_Node : constant Node_Id := Original_Node (N);
...@@ -2809,9 +2807,8 @@ package body Sem_Type is ...@@ -2809,9 +2807,8 @@ package body Sem_Type is
and then Base_Type (T1) = Base_Type (T) and then Base_Type (T1) = Base_Type (T)
and then Is_Numeric_Type (T); and then Is_Numeric_Type (T);
-- for division and multiplication, a user-defined function does -- For division and multiplication, a user-defined function does not
-- not match the predefined universal_fixed operation, except in -- match the predefined universal_fixed operation, except in Ada 83.
-- Ada83 mode.
elsif Op_Name = Name_Op_Divide then elsif Op_Name = Name_Op_Divide then
return (Base_Type (T1) = Base_Type (T2) return (Base_Type (T1) = Base_Type (T2)
...@@ -2892,7 +2889,7 @@ package body Sem_Type is ...@@ -2892,7 +2889,7 @@ package body Sem_Type is
II : Interp_Index; II : Interp_Index;
begin begin
-- Find end of Interp list and copy downward to erase the discarded one -- Find end of interp list and copy downward to erase the discarded one
II := I + 1; II := I + 1;
while Present (All_Interp.Table (II).Typ) loop while Present (All_Interp.Table (II).Typ) loop
...@@ -2903,7 +2900,7 @@ package body Sem_Type is ...@@ -2903,7 +2900,7 @@ package body Sem_Type is
All_Interp.Table (J - 1) := All_Interp.Table (J); All_Interp.Table (J - 1) := All_Interp.Table (J);
end loop; end loop;
-- Back up interp. index to insure that iterator will pick up next -- Back up interp index to insure that iterator will pick up next
-- available interpretation. -- available interpretation.
I := I - 1; I := I - 1;
......
...@@ -103,10 +103,7 @@ package Sem_Type is ...@@ -103,10 +103,7 @@ package Sem_Type is
-- in N. If the name is an expanded name, the homonyms are only those that -- in N. If the name is an expanded name, the homonyms are only those that
-- belong to the same scope. -- belong to the same scope.
function Is_Invisible_Operator function Is_Invisible_Operator (N : Node_Id; T : Entity_Id) return Boolean;
(N : Node_Id;
T : Entity_Id)
return Boolean;
-- Check whether a predefined operation with universal operands appears in -- Check whether a predefined operation with universal operands appears in
-- a context in which the operators of the expected type are not visible. -- a context in which the operators of the expected type are not visible.
...@@ -172,8 +169,7 @@ package Sem_Type is ...@@ -172,8 +169,7 @@ package Sem_Type is
function Disambiguate function Disambiguate
(N : Node_Id; (N : Node_Id;
I1, I2 : Interp_Index; I1, I2 : Interp_Index;
Typ : Entity_Id) Typ : Entity_Id) return Interp;
return Interp;
-- If more than one interpretation of a name in a call is legal, apply -- If more than one interpretation of a name in a call is legal, apply
-- preference rules (universal types first) and operator visibility in -- preference rules (universal types first) and operator visibility in
-- order to remove ambiguity. I1 and I2 are the first two interpretations -- order to remove ambiguity. I1 and I2 are the first two interpretations
...@@ -191,10 +187,7 @@ package Sem_Type is ...@@ -191,10 +187,7 @@ package Sem_Type is
-- right operand, which has one interpretation compatible with that of L. -- right operand, which has one interpretation compatible with that of L.
-- Return the type intersection of the two. -- Return the type intersection of the two.
function Has_Compatible_Type function Has_Compatible_Type (N : Node_Id; Typ : Entity_Id) return Boolean;
(N : Node_Id;
Typ : Entity_Id)
return Boolean;
-- Verify that some interpretation of the node N has a type compatible with -- Verify that some interpretation of the node N has a type compatible with
-- Typ. If N is not overloaded, then its unique type must be compatible -- Typ. If N is not overloaded, then its unique type must be compatible
-- with Typ. Otherwise iterate through the interpretations of N looking for -- with Typ. Otherwise iterate through the interpretations of N looking for
...@@ -220,11 +213,11 @@ package Sem_Type is ...@@ -220,11 +213,11 @@ package Sem_Type is
function Is_Ancestor (T1, T2 : Entity_Id) return Boolean; function Is_Ancestor (T1, T2 : Entity_Id) return Boolean;
-- T1 is a tagged type (not class-wide). Verify that it is one of the -- T1 is a tagged type (not class-wide). Verify that it is one of the
-- ancestors of type T2 (which may or not be class-wide) -- ancestors of type T2 (which may or not be class-wide).
function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean; function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean;
-- Checks whether T1 is any subtype of T2 directly or indirectly. Applies -- Checks whether T1 is any subtype of T2 directly or indirectly. Applies
-- only to scalar subtypes ??? -- only to scalar subtypes???
function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean; function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean;
-- Used to resolve subprograms renaming operators, and calls to user -- Used to resolve subprograms renaming operators, and calls to user
......
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