Skip to content

R
riscv-gcc-1
Commit 8779dffa by Arnaud Charlet
Options

[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
parent 094cefda
Showing with 47 additions and 253 deletions
gcc/ada/ChangeLog
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
......
gcc/ada/einfo.ads
...@@ -6863,7 +6863,7 @@ package Einfo is ...@@ -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.
......
gcc/ada/exp_aggr.adb
...@@ -5599,7 +5599,9 @@ package body Exp_Aggr is ...@@ -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
......
gcc/ada/make.adb
...@@ -1916,8 +1916,7 @@ package body Make is ...@@ -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;
......
gcc/ada/prj-nmsc.adb
...@@ -705,9 +705,13 @@ package body Prj.Nmsc is ...@@ -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
Error_Msg_Name_1 := Unit; if not Source.Duplicate_Unit then
Error_Msg Error_Msg_Name_1 := Unit;
(Data.Flags, "duplicate unit %%", Location, Project); Error_Msg
(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;
......
gcc/ada/prj.ads
...@@ -765,6 +765,9 @@ package Prj is ...@@ -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 ...@@ -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
......
gcc/ada/sem_ch6.adb
...@@ -620,7 +620,12 @@ package body Sem_Ch6 is ...@@ -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",
......
gcc/ada/sem_ch8.adb
...@@ -3076,7 +3076,7 @@ package body Sem_Ch8 is ...@@ -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
......
gcc/ada/xsnames.adb deleted 100644 → 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;
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