[multiple changes]
2010-10-08 Thomas Quinot <quinot@adacore.com> * xsnames.adb: Remove obsolete file. * make.adb, sem_ch8.adb, einfo.ads: Minor reformatting. 2010-10-08 Ed Schonberg <schonberg@adacore.com> * exp_aggr.adb: Complete previous change. 2010-10-08 Ed Schonberg <schonberg@adacore.com> * sem_ch6.adb (Check_Return_Subtype): The subtype indication in an extended return must match statically the return subtype of the enclosing function if the type is an elementary type or if it is constrained. 2010-10-08 Vincent Celier <celier@adacore.com> * prj-nmsc.adb (Add_Source): Report all duplicate units and source file names. Do not report the same duplicate unit several times. * prj.ads (Source_Data): New Boolean component Duplicate_Unit, defaulted to False, to avoid reporting the same unit as duplicate several times. From-SVN: r165160
This commit is contained in:
parent
094cefda51
commit
8779dffad8
|
@ -1,3 +1,27 @@
|
||||||
|
2010-10-08 Thomas Quinot <quinot@adacore.com>
|
||||||
|
|
||||||
|
* xsnames.adb: Remove obsolete file.
|
||||||
|
* make.adb, sem_ch8.adb, einfo.ads: Minor reformatting.
|
||||||
|
|
||||||
|
2010-10-08 Ed Schonberg <schonberg@adacore.com>
|
||||||
|
|
||||||
|
* exp_aggr.adb: Complete previous change.
|
||||||
|
|
||||||
|
2010-10-08 Ed Schonberg <schonberg@adacore.com>
|
||||||
|
|
||||||
|
* sem_ch6.adb (Check_Return_Subtype): The subtype indication in an
|
||||||
|
extended return must match statically the return subtype of the
|
||||||
|
enclosing function if the type is an elementary type or if it is
|
||||||
|
constrained.
|
||||||
|
|
||||||
|
2010-10-08 Vincent Celier <celier@adacore.com>
|
||||||
|
|
||||||
|
* prj-nmsc.adb (Add_Source): Report all duplicate units and source file
|
||||||
|
names. Do not report the same duplicate unit several times.
|
||||||
|
* prj.ads (Source_Data): New Boolean component Duplicate_Unit,
|
||||||
|
defaulted to False, to avoid reporting the same unit as duplicate
|
||||||
|
several times.
|
||||||
|
|
||||||
2010-10-08 Ed Schonberg <schonberg@adacore.com>
|
2010-10-08 Ed Schonberg <schonberg@adacore.com>
|
||||||
|
|
||||||
* sem_aggr.adb (Resolve_Array_Aggregate): If the expression in an
|
* sem_aggr.adb (Resolve_Array_Aggregate): If the expression in an
|
||||||
|
|
|
@ -6863,7 +6863,7 @@ package Einfo is
|
||||||
-- Empty is returned.
|
-- Empty is returned.
|
||||||
|
|
||||||
function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id;
|
function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id;
|
||||||
-- Searches the Rep_Item chain for a given entyt E, for a record
|
-- Searches the Rep_Item chain for a given entity E, for a record
|
||||||
-- representation clause, and if found, returns it. Returns Empty
|
-- representation clause, and if found, returns it. Returns Empty
|
||||||
-- if no such clause is found.
|
-- if no such clause is found.
|
||||||
|
|
||||||
|
|
|
@ -5599,7 +5599,9 @@ package body Exp_Aggr is
|
||||||
-- aggregates for C++ imported types must be expanded.
|
-- aggregates for C++ imported types must be expanded.
|
||||||
|
|
||||||
if Ada_Version >= Ada_05 and then Is_Inherently_Limited_Type (Typ) then
|
if Ada_Version >= Ada_05 and then Is_Inherently_Limited_Type (Typ) then
|
||||||
if Nkind (Parent (N)) /= N_Object_Declaration then
|
if not Nkind_In (Parent (N), N_Object_Declaration,
|
||||||
|
N_Component_Association)
|
||||||
|
then
|
||||||
Convert_To_Assignments (N, Typ);
|
Convert_To_Assignments (N, Typ);
|
||||||
|
|
||||||
elsif Nkind (N) = N_Extension_Aggregate
|
elsif Nkind (N) = N_Extension_Aggregate
|
||||||
|
|
|
@ -1916,8 +1916,7 @@ package body Make is
|
||||||
if ALI_Project = No_Project then
|
if ALI_Project = No_Project then
|
||||||
ALI := No_ALI_Id;
|
ALI := No_ALI_Id;
|
||||||
|
|
||||||
Verbose_Msg
|
Verbose_Msg (Lib_File, " wrong object directory");
|
||||||
(Lib_File, " wrong object directory");
|
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
|
|
@ -705,9 +705,13 @@ package body Prj.Nmsc is
|
||||||
-- (for instance because of symbolic links).
|
-- (for instance because of symbolic links).
|
||||||
|
|
||||||
elsif Source.Path.Name /= Path.Name then
|
elsif Source.Path.Name /= Path.Name then
|
||||||
|
if not Source.Duplicate_Unit then
|
||||||
Error_Msg_Name_1 := Unit;
|
Error_Msg_Name_1 := Unit;
|
||||||
Error_Msg
|
Error_Msg
|
||||||
(Data.Flags, "duplicate unit %%", Location, Project);
|
(Data.Flags, "\duplicate unit %%", Location, Project);
|
||||||
|
Source.Duplicate_Unit := True;
|
||||||
|
end if;
|
||||||
|
|
||||||
Add_Src := False;
|
Add_Src := False;
|
||||||
end if;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
|
|
|
@ -765,6 +765,9 @@ package Prj is
|
||||||
Naming_Exception : Boolean := False;
|
Naming_Exception : Boolean := False;
|
||||||
-- True if the source has an exceptional name
|
-- True if the source has an exceptional name
|
||||||
|
|
||||||
|
Duplicate_Unit : Boolean := False;
|
||||||
|
-- True when a duplicate unit has been reported for this source
|
||||||
|
|
||||||
Next_In_Lang : Source_Id := No_Source;
|
Next_In_Lang : Source_Id := No_Source;
|
||||||
-- Link to another source of the same language in the same project
|
-- Link to another source of the same language in the same project
|
||||||
end record;
|
end record;
|
||||||
|
@ -799,6 +802,7 @@ package Prj is
|
||||||
Switches_Path => No_Path,
|
Switches_Path => No_Path,
|
||||||
Switches_TS => Empty_Time_Stamp,
|
Switches_TS => Empty_Time_Stamp,
|
||||||
Naming_Exception => False,
|
Naming_Exception => False,
|
||||||
|
Duplicate_Unit => False,
|
||||||
Next_In_Lang => No_Source);
|
Next_In_Lang => No_Source);
|
||||||
|
|
||||||
package Source_Paths_Htable is new Simple_HTable
|
package Source_Paths_Htable is new Simple_HTable
|
||||||
|
|
|
@ -620,7 +620,12 @@ package body Sem_Ch6 is
|
||||||
Subtype_Ind);
|
Subtype_Ind);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
if Is_Constrained (R_Type) then
|
-- AI05-103 : for elementary types, subtypes must statically
|
||||||
|
-- match.
|
||||||
|
|
||||||
|
if Is_Constrained (R_Type)
|
||||||
|
or else Is_Access_Type (R_Type)
|
||||||
|
then
|
||||||
if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
|
if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
|
||||||
Error_Msg_N
|
Error_Msg_N
|
||||||
("subtype must statically match function result subtype",
|
("subtype must statically match function result subtype",
|
||||||
|
|
|
@ -3076,7 +3076,7 @@ package body Sem_Ch8 is
|
||||||
|
|
||||||
-- The replacement of a discriminant by the corresponding discriminal
|
-- The replacement of a discriminant by the corresponding discriminal
|
||||||
-- is not done for a task discriminant that appears in a default
|
-- is not done for a task discriminant that appears in a default
|
||||||
-- expression of an entry parameter. See Expand_Discriminant in exp_ch2
|
-- expression of an entry parameter. See Exp_Ch2.Expand_Discriminant
|
||||||
-- for details on their handling.
|
-- for details on their handling.
|
||||||
|
|
||||||
elsif Is_Concurrent_Type (Scope (E)) then
|
elsif Is_Concurrent_Type (Scope (E)) then
|
||||||
|
|
|
@ -1,244 +0,0 @@
|
||||||
------------------------------------------------------------------------------
|
|
||||||
-- --
|
|
||||||
-- GNAT SYSTEM UTILITIES --
|
|
||||||
-- --
|
|
||||||
-- X S N A M E S --
|
|
||||||
-- --
|
|
||||||
-- B o d y --
|
|
||||||
-- --
|
|
||||||
-- Copyright (C) 1992-2008, 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- --
|
|
||||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
||||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
||||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
||||||
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
||||||
-- for more details. You should have received a copy of the GNU General --
|
|
||||||
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
||||||
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
||||||
-- --
|
|
||||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
||||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
||||||
-- --
|
|
||||||
------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
-- This utility is used to make a new version of the Snames package when new
|
|
||||||
-- names are added to the spec, the existing versions of snames.ads and
|
|
||||||
-- snames.adb and snames.h are read, and updated to match the set of names in
|
|
||||||
-- snames.ads. The updated versions are written to snames.ns, snames.nb (new
|
|
||||||
-- spec/body), and snames.nh (new header file).
|
|
||||||
|
|
||||||
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
|
|
||||||
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
|
|
||||||
with Ada.Strings.Maps; use Ada.Strings.Maps;
|
|
||||||
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
|
|
||||||
with Ada.Text_IO; use Ada.Text_IO;
|
|
||||||
|
|
||||||
with GNAT.Spitbol; use GNAT.Spitbol;
|
|
||||||
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
|
|
||||||
|
|
||||||
procedure XSnames is
|
|
||||||
|
|
||||||
InB : File_Type;
|
|
||||||
InS : File_Type;
|
|
||||||
OutS : File_Type;
|
|
||||||
OutB : File_Type;
|
|
||||||
InH : File_Type;
|
|
||||||
OutH : File_Type;
|
|
||||||
|
|
||||||
A, B : VString := Nul;
|
|
||||||
Line : VString := Nul;
|
|
||||||
Name : VString := Nul;
|
|
||||||
Name1 : VString := Nul;
|
|
||||||
Oval : VString := Nul;
|
|
||||||
Restl : VString := Nul;
|
|
||||||
|
|
||||||
Tdigs : constant Pattern := Any (Decimal_Digit_Set) &
|
|
||||||
Any (Decimal_Digit_Set) &
|
|
||||||
Any (Decimal_Digit_Set);
|
|
||||||
|
|
||||||
Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name
|
|
||||||
& Span (' ') * B
|
|
||||||
& ": constant Name_Id := N + " & Tdigs
|
|
||||||
& ';' & Rest * Restl;
|
|
||||||
|
|
||||||
Get_Name : constant Pattern := "Name_" & Rest * Name1;
|
|
||||||
Chk_Low : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
|
|
||||||
Findu : constant Pattern := Span ('u') * A;
|
|
||||||
|
|
||||||
Val : Natural;
|
|
||||||
|
|
||||||
Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_");
|
|
||||||
|
|
||||||
M : Match_Result;
|
|
||||||
|
|
||||||
type Header_Symbol is (None, Attr, Conv, Prag);
|
|
||||||
-- A symbol in the header file
|
|
||||||
|
|
||||||
procedure Output_Header_Line (S : Header_Symbol);
|
|
||||||
-- Output header line
|
|
||||||
|
|
||||||
Header_Attr : aliased String := "Attr";
|
|
||||||
Header_Conv : aliased String := "Convention";
|
|
||||||
Header_Prag : aliased String := "Pragma";
|
|
||||||
-- Prefixes used in the header file
|
|
||||||
|
|
||||||
type String_Ptr is access all String;
|
|
||||||
Header_Prefix : constant array (Header_Symbol) of String_Ptr :=
|
|
||||||
(null,
|
|
||||||
Header_Attr'Access,
|
|
||||||
Header_Conv'Access,
|
|
||||||
Header_Prag'Access);
|
|
||||||
|
|
||||||
-- Patterns used in the spec file
|
|
||||||
|
|
||||||
Get_Attr : constant Pattern := Span (' ') & "Attribute_"
|
|
||||||
& Break (",)") * Name1;
|
|
||||||
Get_Conv : constant Pattern := Span (' ') & "Convention_"
|
|
||||||
& Break (",)") * Name1;
|
|
||||||
Get_Prag : constant Pattern := Span (' ') & "Pragma_"
|
|
||||||
& Break (",)") * Name1;
|
|
||||||
|
|
||||||
type Header_Symbol_Counter is array (Header_Symbol) of Natural;
|
|
||||||
Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0);
|
|
||||||
|
|
||||||
Header_Current_Symbol : Header_Symbol := None;
|
|
||||||
Header_Pending_Line : VString := Nul;
|
|
||||||
|
|
||||||
------------------------
|
|
||||||
-- Output_Header_Line --
|
|
||||||
------------------------
|
|
||||||
|
|
||||||
procedure Output_Header_Line (S : Header_Symbol) is
|
|
||||||
begin
|
|
||||||
-- Skip all the #define for S-prefixed symbols in the header.
|
|
||||||
-- Of course we are making implicit assumptions:
|
|
||||||
-- (1) No newline between symbols with the same prefix.
|
|
||||||
-- (2) Prefix order is the same as in snames.ads.
|
|
||||||
|
|
||||||
if Header_Current_Symbol /= S then
|
|
||||||
declare
|
|
||||||
Pat : constant String := "#define " & Header_Prefix (S).all;
|
|
||||||
In_Pat : Boolean := False;
|
|
||||||
|
|
||||||
begin
|
|
||||||
if Header_Current_Symbol /= None then
|
|
||||||
Put_Line (OutH, Header_Pending_Line);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
loop
|
|
||||||
Line := Get_Line (InH);
|
|
||||||
|
|
||||||
if Match (Line, Pat) then
|
|
||||||
In_Pat := True;
|
|
||||||
elsif In_Pat then
|
|
||||||
Header_Pending_Line := Line;
|
|
||||||
exit;
|
|
||||||
else
|
|
||||||
Put_Line (OutH, Line);
|
|
||||||
end if;
|
|
||||||
end loop;
|
|
||||||
|
|
||||||
Header_Current_Symbol := S;
|
|
||||||
end;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
-- Now output the line
|
|
||||||
|
|
||||||
Put_Line (OutH, "#define " & Header_Prefix (S).all
|
|
||||||
& "_" & Name1 & (30 - Length (Name1)) * ' '
|
|
||||||
& Header_Counter (S));
|
|
||||||
Header_Counter (S) := Header_Counter (S) + 1;
|
|
||||||
end Output_Header_Line;
|
|
||||||
|
|
||||||
-- Start of processing for XSnames
|
|
||||||
|
|
||||||
begin
|
|
||||||
Open (InB, In_File, "snames.adb");
|
|
||||||
Open (InS, In_File, "snames.ads");
|
|
||||||
Open (InH, In_File, "snames.h");
|
|
||||||
|
|
||||||
Create (OutS, Out_File, "snames.ns");
|
|
||||||
Create (OutB, Out_File, "snames.nb");
|
|
||||||
Create (OutH, Out_File, "snames.nh");
|
|
||||||
|
|
||||||
Anchored_Mode := True;
|
|
||||||
Val := 0;
|
|
||||||
|
|
||||||
loop
|
|
||||||
Line := Get_Line (InB);
|
|
||||||
exit when Match (Line, " Preset_Names");
|
|
||||||
Put_Line (OutB, Line);
|
|
||||||
end loop;
|
|
||||||
|
|
||||||
Put_Line (OutB, Line);
|
|
||||||
|
|
||||||
LoopN : while not End_Of_File (InS) loop
|
|
||||||
Line := Get_Line (InS);
|
|
||||||
|
|
||||||
if not Match (Line, Name_Ref) then
|
|
||||||
Put_Line (OutS, Line);
|
|
||||||
|
|
||||||
if Match (Line, Get_Attr) then
|
|
||||||
Output_Header_Line (Attr);
|
|
||||||
elsif Match (Line, Get_Conv) then
|
|
||||||
Output_Header_Line (Conv);
|
|
||||||
elsif Match (Line, Get_Prag) then
|
|
||||||
Output_Header_Line (Prag);
|
|
||||||
end if;
|
|
||||||
else
|
|
||||||
Oval := Lpad (V (Val), 3, '0');
|
|
||||||
|
|
||||||
if Match (Name, "Last_") then
|
|
||||||
Oval := Lpad (V (Val - 1), 3, '0');
|
|
||||||
end if;
|
|
||||||
|
|
||||||
Put_Line
|
|
||||||
(OutS, A & Name & B & ": constant Name_Id := N + "
|
|
||||||
& Oval & ';' & Restl);
|
|
||||||
|
|
||||||
if Match (Name, Get_Name) then
|
|
||||||
Name := Name1;
|
|
||||||
Val := Val + 1;
|
|
||||||
|
|
||||||
if Match (Name, Findu, M) then
|
|
||||||
Replace (M, Translate (A, Xlate_U_Und));
|
|
||||||
Translate (Name, Lower_Case_Map);
|
|
||||||
|
|
||||||
elsif not Match (Name, "Op_", "") then
|
|
||||||
Translate (Name, Lower_Case_Map);
|
|
||||||
|
|
||||||
else
|
|
||||||
Name := 'O' & Translate (Name, Lower_Case_Map);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
if Name = "error" then
|
|
||||||
Name := V ("<error>");
|
|
||||||
end if;
|
|
||||||
|
|
||||||
if not Match (Name, Chk_Low) then
|
|
||||||
Put_Line (OutB, " """ & Name & "#"" &");
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
end loop LoopN;
|
|
||||||
|
|
||||||
loop
|
|
||||||
Line := Get_Line (InB);
|
|
||||||
exit when Match (Line, " ""#"";");
|
|
||||||
end loop;
|
|
||||||
|
|
||||||
Put_Line (OutB, Line);
|
|
||||||
|
|
||||||
while not End_Of_File (InB) loop
|
|
||||||
Line := Get_Line (InB);
|
|
||||||
Put_Line (OutB, Line);
|
|
||||||
end loop;
|
|
||||||
|
|
||||||
Put_Line (OutH, Header_Pending_Line);
|
|
||||||
while not End_Of_File (InH) loop
|
|
||||||
Line := Get_Line (InH);
|
|
||||||
Put_Line (OutH, Line);
|
|
||||||
end loop;
|
|
||||||
end XSnames;
|
|
Loading…
Reference in New Issue