+2009-07-13 Robert Dewar <dewar@adacore.com>
+
+ * prj.ads, prj-dect.adb, prj-err.ads, prj-err.adb, prj-nmsc.adb,
+ prj-strt.ads: Minor reformatting
+
+2009-07-13 Thomas Quinot <quinot@adacore.com>
+
+ * exp_dist.adb (Build_From_Any_Call): For the case of a generic type,
+ set the type of the From_Any call to the base type.
+
+2009-07-13 Doug Rupp <rupp@adacore.com>
+
+ * symbols-processing-vms-ia64.adb (Process): Add variables and
+ constants to retrieve and check for symbol visibility.
+
+2009-07-13 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Unchecked_Type_Conversion): If conversion is to
+ the identical type we remove the conversion completely because
+ it is useless.
+
2009-07-13 Emmanuel Briot <briot@adacore.com>
* prj-err.adb (Error_Msg): One more case where a message should be
-- the conversion completely, it is useless.
if Operand_Type = Target_Type then
+
+ -- Propagate Assignment_OK attribute to the operand
+
+ if Assignment_OK (N) then
+ Set_Assignment_OK (Operand);
+ end if;
+
Rewrite (N, Relocate_Node (Operand));
return;
end if;
Operand_Type : constant Entity_Id := Etype (Operand);
begin
+ -- Nothing at all to do if conversion is to the identical type so remove
+ -- the conversion completely, it is useless.
+
+ if Operand_Type = Target_Type then
+
+ -- Propagate Assignment_OK attribute to the operand
+
+ if Assignment_OK (N) then
+ Set_Assignment_OK (Operand);
+ end if;
+
+ Rewrite (N, Relocate_Node (Operand));
+ return;
+ end if;
+
-- If we have a conversion of a compile time known value to a target
-- type and the value is in range of the target type, then we can simply
-- replace the construct by an integer literal of the correct type. We
else
declare
Decl : Entity_Id;
- Typ : Entity_Id := U_Type;
begin
-- For the subtype representing a generic actual type, go
-- to the base type.
- if Is_Generic_Actual_Type (Typ) then
- Typ := Base_Type (Typ);
+ if Is_Generic_Actual_Type (U_Type) then
+ U_Type := Base_Type (U_Type);
end if;
- Build_From_Any_Function (Loc, Typ, Decl, Fnam);
+ Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
Append_To (Decls, Decl);
end;
end if;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean;
Flags : Processing_Flags);
- -- Parse declarative items. Depending on In_Zone, some declarative
- -- items may be forbidden.
- -- Is_Config_File should be set to True if the project represents a config
- -- file (.cgpr) since some specific checks apply.
+ -- Parse declarative items. Depending on In_Zone, some declarative items
+ -- may be forbidden. Is_Config_File should be set to True if the project
+ -- represents a config file (.cgpr) since some specific checks apply.
procedure Parse_Package_Declaration
(In_Tree : Project_Node_Tree_Ref;
end if;
if Real_Location = No_Location then
+
-- If still null, we are parsing a project that was created in-memory
-- so we shouldn't report errors for projects that the user has no
-- access to in any case.
+
return;
end if;
if Flags.Report_Error /= null then
Flags.Report_Error
(Project,
- Is_Warning => Msg (Msg'First) = '?' or Msg (Msg'First) = '<');
+ Is_Warning => Msg (Msg'First) = '?' or else Msg (Msg'First) = '<');
end if;
end Error_Msg;
Location : Source_Ptr := No_Location;
Project : Project_Id := null);
-- Output an error message, either through Flags.Error_Report or through
- -- Errutil. The location defaults to the project's location ("project" in
- -- the source code).
- -- If Msg starts with "?", this is a warning, and Warning: is added at the
- -- beginning. If Msg starts with "<", see comment for
- -- Err_Vars.Error_Msg_Warn
+ -- Errutil. The location defaults to the project's location ("project"
+ -- in the source code). If Msg starts with "?", this is a warning, and
+ -- Warning: is added at the beginning. If Msg starts with "<", see comment
+ -- for Err_Vars.Error_Msg_Warn.
-------------
-- Scanner --
Kind : Source_Kind;
File_Name : File_Name_Type;
Display_File : File_Name_Type;
- Naming_Exception : Boolean := False;
+ Naming_Exception : Boolean := False;
Path : Path_Information := No_Path_Information;
- Alternate_Languages : Language_List := null;
- Unit : Name_Id := No_Name;
- Index : Int := 0;
- Locally_Removed : Boolean := False;
- Location : Source_Ptr := No_Location);
+ Alternate_Languages : Language_List := null;
+ Unit : Name_Id := No_Name;
+ Index : Int := 0;
+ Locally_Removed : Boolean := False;
+ Location : Source_Ptr := No_Location);
-- Add a new source to the different lists: list of all sources in the
-- project tree, list of source of a project and list of sources of a
-- language.
Kind : Source_Kind;
File_Name : File_Name_Type;
Display_File : File_Name_Type;
- Naming_Exception : Boolean := False;
+ Naming_Exception : Boolean := False;
Path : Path_Information := No_Path_Information;
- Alternate_Languages : Language_List := null;
- Unit : Name_Id := No_Name;
- Index : Int := 0;
- Locally_Removed : Boolean := False;
- Location : Source_Ptr := No_Location)
+ Alternate_Languages : Language_List := null;
+ Unit : Name_Id := No_Name;
+ Index : Int := 0;
+ Locally_Removed : Boolean := False;
+ Location : Source_Ptr := No_Location)
is
Config : constant Language_Config := Lang_Id.Config;
UData : Unit_Index;
Add_Src : Boolean;
Source : Source_Id;
Prev_Unit : Unit_Index := No_Unit_Index;
+
Source_To_Replace : Source_Id := No_Source;
begin
end if;
end if;
- -- Do not allow the same unit name in different projects,
- -- except if one is extending the other.
+ -- Do not allow the same unit name in different projects, except
+ -- if one is extending the other.
- -- For a file based language, the same file name replaces
- -- a file in a project being extended, but it is allowed
- -- to have the same file name in unrelated projects.
+ -- For a file based language, the same file name replaces a file
+ -- in a project being extended, but it is allowed to have the same
+ -- file name in unrelated projects.
elsif Is_Extending (Project, Source.Project) then
if not Locally_Removed then
-- On entry, the current token is the first literal string following
-- a left parenthesis in a string type declaration such as:
-- type Toto is ("string_1", "string_2", "string_3");
- -- On exit, the current token is the right parenthesis.
- -- The parameter First_String is a node that contained the first
- -- literal string of the string type, linked with the following
- -- literal strings.
+ --
+ -- On exit, the current token is the right parenthesis. The parameter
+ -- First_String is a node that contained the first literal string of the
+ -- string type, linked with the following literal strings.
--
-- Report an error if
-- - a literal string is not found at the beginning of the list
procedure Start_New_Case_Construction
(In_Tree : Project_Node_Tree_Ref;
String_Type : Project_Node_Id);
- -- This procedure is called at the beginning of a case construction
- -- The parameter String_Type is the node for the string type
- -- of the case label variable.
- -- The different literal strings of the string type are stored
- -- into a table to be checked against the case labels of the
- -- case construction.
+ -- This procedure is called at the beginning of a case construction The
+ -- parameter String_Type is the node for the string type of the case label
+ -- variable. The different literal strings of the string type are stored
+ -- into a table to be checked against the case labels of the case
+ -- construction.
procedure End_Case_Construction
(Check_All_Labels : Boolean;
Case_Location : Source_Ptr;
Flags : Processing_Flags);
- -- This procedure is called at the end of a case construction
- -- to remove the case labels and to restore the previous state.
- -- In particular, in the case of nested case constructions,
- -- the case labels of the enclosing case construction are restored.
- -- When When_Others is False and we are not in quiet output, a warning
- -- is emitted for each value of the case variable string type that has
- -- not been specified.
+ -- This procedure is called at the end of a case construction to remove the
+ -- case labels and to restore the previous state. In particular, in the
+ -- case of nested case constructions, the case labels of the enclosing case
+ -- construction are restored. When When_Others is False and we are not in
+ -- quiet output, a warning is emitted for each value of the case variable
+ -- string type that has not been specified.
procedure Parse_Choice_List
(In_Tree : Project_Node_Tree_Ref;
Current_Package : Project_Node_Id;
Optional_Index : Boolean;
Flags : Processing_Flags);
- -- Parse a simple string expression or a string list expression.
- -- Current_Project is the node of the project file being parsed.
- -- Current_Package is the node of the package being parsed,
- -- or Empty_Node when we are at the project level (not in a package).
- -- On exit, Expression is the node of the expression that has
- -- been parsed.
+ -- Parse a simple string expression or a string list expression
+ --
+ -- Current_Project is the node of the project file being parsed
+ --
+ -- Current_Package is the node of the package being parsed, or Empty_Node
+ -- when we are at the project level (not in a package). On exit, Expression
+ -- is the node of the expression that has been parsed.
procedure Parse_Variable_Reference
(In_Tree : Project_Node_Tree_Ref;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Flags : Processing_Flags);
- -- Parse a variable or attribute reference.
- -- Used internally (in expressions) and for case variables (in Prj.Dect).
- -- Current_Package is the node of the package being parsed,
- -- or Empty_Node when we are at the project level (not in a package).
- -- On exit, Variable is the node of the variable or attribute reference.
- -- A variable reference is made of one to three simple names.
- -- An attribute reference is made of one or two simple names,
+ -- Parse variable or attribute reference. Used internally (in expressions)
+ -- and for case variables (in Prj.Dect). Current_Package is the node of the
+ -- package being parsed, or Empty_Node when we are at the project level
+ -- (not in a package). On exit, Variable is the node of the variable or
+ -- attribute reference. A variable reference is made of one to three simple
+ -- names. An attribute reference is made of one or two simple names,
-- followed by an apostrophe, followed by the attribute simple name.
end Prj.Strt;
-- - Error: issue an error, causes the tool to fail
type Error_Handler is access procedure
- (Project : Project_Id; Is_Warning : Boolean);
+ (Project : Project_Id;
+ Is_Warning : Boolean);
-- This warngs when an error was found when parsing a project. The error
- -- itself is handled through Prj.Err (and you should call
- -- Prj.Err.Finalize to actually print the error). This ensures that
- -- duplicate error messages are always correctly removed, that errors msgs
- -- are sorted, and that all tools will report the same error to the user.
+ -- itself is handled through Prj.Err (and Prj.Err.Finalize should be called
+ -- to actually print the error). This ensures that duplicate error messages
+ -- are always correctly removed, that errors msgs are sorted, and that all
+ -- tools will report the same error to the user.
function Create_Flags
(Report_Error : Error_Handler;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2009, 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- --
Stname : Integer;
Stinfo : Character;
+ Stother : Character;
Sttype : Integer;
Stbind : Integer;
Stshndx : Integer;
+ Stvis : Integer;
+
+ STV_Internal : constant := 1;
+ STV_Hidden : constant := 2;
Section_Headers : Section_Header_Ptr;
while Offset < End_Symtab loop
Get_Word (Stname);
Get_Byte (Stinfo);
- Get_Byte (B);
+ Get_Byte (Stother);
Get_Half (Stshndx);
for J in 1 .. 4 loop
Get_Word (W);
Sttype := Integer'(Character'Pos (Stinfo)) mod 16;
Stbind := Integer'(Character'Pos (Stinfo)) / 16;
+ Stvis := Integer'(Character'Pos (Stother)) mod 4;
if (Sttype = 1 or else Sttype = 2)
and then Stbind /= 0
and then Stshndx /= 0
+ and then Stvis /= STV_Internal
+ and then Stvis /= STV_Hidden
then
-- Check if this is a symbol from a generic body
OSDN Git Service
