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

re PR ada/5677 (Assert failure in nlists.adb:933) 

2003-10-22  Arnaud Charlet  <charlet@act-europe.fr>

	* gnat_wrapper.adb: New file.

2003/10/22  Jerome Roussel  <roussel@act-europe.fr>

	* g-regpat.ads, g-regpat.adb (Match): new function, to know if a
	string match a pre compiled regular expression (the corresponding
	version of the function working on a raw regular expression)
	Fix typos in various comments
	Update copyright notice in spec

2003/10/21  Gary Dismukes  <dismukes@gnat.com>

	* exp_ch3.adb:
	(Component_Needs_Simple_Initialization): Return False when the type is a
	packed bit array. Revise spec comments to document this case.

	* exp_prag.adb:
	(Expand_Pragma_Import): Set any expression on the imported object to
	empty to avoid initializing imported objects (in particular this
	covers the case of zero-initialization of bit arrays).
	Update copyright notice.

2003/10/21  Ed Schonberg  <schonberg@gnat.com>

	* sem_ch12.adb:
	(Load_Parent_Of_Generic): If parent is compilation unit, stop search,
	a subunit is missing.
	(Instantiate_Subprogram_Body): If body of function is missing, set type
	of return expression explicitly in dummy body, to prevent cascaded
	errors when a subunit is missing.
	Fixes PR 5677.

	* sem_ch3.adb:
	(Access_Subprogram_Declaration): Verify that return type is valid.
	Fixes PR 8693.

	* sem_elab.adb:
	(Check_Elab_Calls): Do not apply elaboration checks if the main unit is
	generic.
	Fixes PR 12318.

	* sem_util.adb:
	(Corresponding_Discriminant): If the scope of the discriminant is a
	private type without discriminant, use its full view.
	Fixes PR 8247.

From-SVN: r72792
This commit is contained in:
Arnaud Charlet 2003-10-22 11:28:08 +02:00 committed by Arnaud Charlet
parent 12be91a78c
commit 0c644933b8
10 changed files with 250 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
gcc/ada/ChangeLog
View File

@ -1,6 +1,51 @@
2003-10-22 Arnaud Charlet <charlet@act-europe.fr>
* mingw32.h: New file.
* gnat_wrapper.adb: New file.
2003/10/22 Jerome Roussel <roussel@act-europe.fr>
* g-regpat.ads, g-regpat.adb (Match): new function, to know if a
string match a pre compiled regular expression (the corresponding
version of the function working on a raw regular expression)
Fix typos in various comments
Update copyright notice in spec
2003/10/21 Gary Dismukes <dismukes@gnat.com>
* exp_ch3.adb:
(Component_Needs_Simple_Initialization): Return False when the type is a
packed bit array. Revise spec comments to document this case.
* exp_prag.adb:
(Expand_Pragma_Import): Set any expression on the imported object to
empty to avoid initializing imported objects (in particular this
covers the case of zero-initialization of bit arrays).
Update copyright notice.
2003/10/21 Ed Schonberg <schonberg@gnat.com>
* sem_ch12.adb:
(Load_Parent_Of_Generic): If parent is compilation unit, stop search,
a subunit is missing.
(Instantiate_Subprogram_Body): If body of function is missing, set type
of return expression explicitly in dummy body, to prevent cascaded
errors when a subunit is missing.
Fixes PR 5677.
* sem_ch3.adb:
(Access_Subprogram_Declaration): Verify that return type is valid.
Fixes PR 8693.
* sem_elab.adb:
(Check_Elab_Calls): Do not apply elaboration checks if the main unit is
generic.
Fixes PR 12318.
* sem_util.adb:
(Corresponding_Discriminant): If the scope of the discriminant is a
private type without discriminant, use its full view.
Fixes PR 8247.
2003-10-21 Arnaud Charlet <charlet@act-europe.fr>

20
gcc/ada/exp_ch3.adb
View File

@ -1368,11 +1368,18 @@ package body Exp_Ch3 is
(T : Entity_Id)
return Boolean;
-- Determines if a component needs simple initialization, given its
-- type T. This is identical to Needs_Simple_Initialization, except
-- that the types Tag and Vtable_Ptr, which are access types which
-- would normally require simple initialization to null, do not
-- require initialization as components, since they are explicitly
-- initialized by other means.
-- type T. This is the same as Needs_Simple_Initialization except
-- for the following differences. The types Tag and Vtable_Ptr,
-- which are access types which would normally require simple
-- initialization to null, do not require initialization as
-- components, since they are explicitly initialized by other
-- means. The other relaxation is for packed bit arrays that are
-- associated with a modular type, which in some cases require
-- zero initialization to properly support comparisons, except
-- that comparison of such components always involves an explicit
-- selection of only the component's specific bits (whether or not
-- there are adjacent components or gaps), so zero initialization
-- is never needed for components.
procedure Constrain_Array
(SI : Node_Id;
@ -2144,7 +2151,8 @@ package body Exp_Ch3 is
return
Needs_Simple_Initialization (T)
and then not Is_RTE (T, RE_Tag)
and then not Is_RTE (T, RE_Vtable_Ptr);
and then not Is_RTE (T, RE_Vtable_Ptr)
and then not Is_Bit_Packed_Array (T);
end Component_Needs_Simple_Initialization;
---------------------

10
gcc/ada/exp_prag.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2003 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- --
@ -295,7 +295,13 @@ package body Exp_Prag is
then
Remove (After_Def);
elsif Is_Access_Type (Typ) then
-- Any default initialization expression should be removed
-- (e.g., null defaults for access objects, zero initialization
-- of packed bit arrays). Imported objects aren't allowed to
-- have explicit initialization, so the expression must have
-- been generated by the compiler.
elsif Present (Expression (Parent (Def_Id))) then
Set_Expression (Parent (Def_Id), Empty);
end if;
end if;

14
gcc/ada/g-regpat.adb
View File

@ -3402,6 +3402,20 @@ package body GNAT.Regpat is
end if;
end Match;
function Match
(Self : Pattern_Matcher;
Data : String;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
return Boolean
is
Matches : Match_Array (0 .. 0);
begin
Match (Self, Data, Matches, Data_First, Data_Last);
return Matches (0).First >= Data'First;
end Match;
procedure Match
(Expression : String;
Data : String;

23
gcc/ada/g-regpat.ads
View File

@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1986 by University of Toronto. --
-- Copyright (C) 1996-2002 Ada Core Technologies, Inc. --
-- Copyright (C) 1996-2003 Ada Core Technologies, 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- --
@ -475,7 +475,7 @@ pragma Preelaborate (Regpat);
(Expression : String;
Data : String;
Size : Program_Size := 0;
Data_First : Integer := -1;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
return Natural;
-- Return the position where Data matches, or (Data'First - 1) if
@ -492,7 +492,7 @@ pragma Preelaborate (Regpat);
(Expression : String;
Data : String;
Size : Program_Size := 0;
Data_First : Integer := -1;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
return Boolean;
-- Return True if Data matches Expression. Match raises Storage_Error
@ -517,10 +517,20 @@ pragma Preelaborate (Regpat);
Data : String;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
return Natural;
return Natural;
-- Match Data using the given pattern matcher.
-- Return the position where Data matches, or (Data'First - 1) if there is
-- no match. Raises Expression_Error if Expression is not a legal regular
-- expression.
-- no match.
--
-- See description of Data_First and Data_Last above.
function Match
(Self : Pattern_Matcher;
Data : String;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
return Boolean;
-- Return True if Data matches using the given pattern matcher.
--
-- See description of Data_First and Data_Last above.
@ -534,7 +544,6 @@ pragma Preelaborate (Regpat);
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last);
-- Match Data using the given pattern matcher and store result in Matches.
-- Raises Expression_Error if Expression is not a legal regular expression.
-- The expression matches if Matches (0) /= No_Match.
--
-- At most Matches'Length parenthesis are returned.

121
gcc/ada/gnat_wrapper.adb Normal file
View File

@ -0,0 +1,121 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T _ W R A P P E R --
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2003 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- GNAT_Wrapper is to be used as the starter program for most of the GNAT
-- executables. It sets up the working environment variables and calls the
-- real executable which is to be found under the 'real' sub-directory.
--
-- This avoids using the registry on Windows which is tricky to setup to run
-- multiple compilers (GNAT Pro release and wavefronts for example) at the
-- same time.
with Ada.Command_Line; use Ada.Command_Line;
with GNAT.OS_Lib; use GNAT.OS_Lib;
procedure GNAT_Wrapper is
DS : Character renames Directory_Separator;
PS : Character renames Path_Separator;
procedure Split_Command;
-- Parse Actual_Name and set K and L variables (see below).
Actual_Name : String_Access := new String'(Command_Name);
K : Natural;
-- Index of the directory separator just before program name's first
-- character.
L : Natural;
-- Index of the last character of the GNATPRO install directory.
LD_LIBRARY_PATH : String_Access := Getenv ("LD_LIBRARY_PATH");
PATH : String_Access := Getenv ("PATH");
-------------------
-- Split_Command --
-------------------
procedure Split_Command is
begin
K := Actual_Name'Last;
loop
exit when K = 0
or else Actual_Name (K) = '\' or else Actual_Name (K) = '/';
K := K - 1;
end loop;
end Split_Command;
begin
Split_Command;
if K = 0 then
-- No path information found, locate the program on the path.
declare
Old : String_Access := Actual_Name;
begin
Actual_Name := Locate_Exec_On_Path (Actual_Name.all);
Free (Old);
Split_Command;
end;
end if;
-- Skip 'bin' from directory above. GNAT binaries are always under
-- <gnatpro>/bin directory.
L := K - 4;
declare
Prog : constant String := Actual_Name (K + 1 .. Actual_Name'Last);
Dir : constant String := Actual_Name (Actual_Name'First .. L - 1);
Real : constant String := Dir & DS & ".bin";
Bin : constant String := Dir & DS & "bin";
Args : Argument_List (1 .. Argument_Count);
Result : Integer;
begin
Setenv ("GCC_ROOT", Dir);
Setenv ("GNAT_ROOT", Dir);
Setenv ("BINUTILS_ROOT", Dir);
Setenv ("LD_LIBRARY_PATH", Dir & DS & "lib" & PS & LD_LIBRARY_PATH.all);
Setenv ("PATH", Real & PS & Bin & PS & PATH.all);
-- Call the right executable under "<dir>/.bin"
for K in 1 .. Argument_Count loop
Args (K) := new String'(Argument (K));
end loop;
Normalize_Arguments (Args);
Result := Spawn (Real & DS & Prog, Args);
for K in 1 .. Argument_Count loop
Free (Args (K));
end loop;
OS_Exit (Result);
end;
end GNAT_Wrapper;

17
gcc/ada/sem_ch12.adb
View File

@ -7175,6 +7175,7 @@ package body Sem_Ch12 is
Act_Body_Id : Entity_Id;
Pack_Body : Node_Id;
Prev_Formal : Entity_Id;
Ret_Expr : Node_Id;
Unit_Renaming : Node_Id;
Parent_Installed : Boolean := False;
@ -7351,6 +7352,13 @@ package body Sem_Ch12 is
PE_Access_Before_Elaboration))));
else
Ret_Expr :=
Make_Raise_Program_Error (Loc,
Reason => PE_Access_Before_Elaboration);
Set_Etype (Ret_Expr, (Etype (Anon_Id)));
Set_Analyzed (Ret_Expr);
Act_Body :=
Make_Subprogram_Body (Loc,
Specification =>
@ -7365,12 +7373,8 @@ package body Sem_Ch12 is
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Return_Statement (Loc,
Expression =>
Make_Raise_Program_Error (Loc,
Reason =>
PE_Access_Before_Elaboration)))));
Statements =>
New_List (Make_Return_Statement (Loc, Ret_Expr))));
end if;
Pack_Body := Make_Package_Body (Loc,
@ -8209,6 +8213,7 @@ package body Sem_Ch12 is
elsif Nkind (True_Parent) = N_Package_Declaration
and then Present (Generic_Parent (Specification (True_Parent)))
and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit
then
-- Parent is an instantiation within another specification.
-- Declaration for instance has been inserted before original

5
gcc/ada/sem_ch3.adb
View File

@ -734,6 +734,11 @@ package body Sem_Ch3 is
if Nkind (T_Def) = N_Access_Function_Definition then
Analyze (Subtype_Mark (T_Def));
Set_Etype (Desig_Type, Entity (Subtype_Mark (T_Def)));
if not (Is_Type (Etype (Desig_Type))) then
Error_Msg_N
("expect type in function specification", Subtype_Mark (T_Def));
end if;
else
Set_Etype (Desig_Type, Standard_Void_Type);
end if;

5
gcc/ada/sem_elab.adb
View File

@ -1177,7 +1177,10 @@ package body Sem_Elab is
-- case we lack the full information that we need, and no object
-- file will be created in any case.
if not Expander_Active or else Subunits_Missing then
if not Expander_Active
or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
or else Subunits_Missing
then
return;
end if;

13
gcc/ada/sem_util.adb
View File

@ -1967,7 +1967,18 @@ package body Sem_Util is
begin
Par_Disc := Original_Record_Component (Original_Discriminant (Id));
Old_Disc := First_Discriminant (Scope (Par_Disc));
-- The original type may currently be private, and the discriminant
-- only appear on its full view.
if Is_Private_Type (Scope (Par_Disc))
and then not Has_Discriminants (Scope (Par_Disc))
and then Present (Full_View (Scope (Par_Disc)))
then
Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
else
Old_Disc := First_Discriminant (Scope (Par_Disc));
end if;
if Is_Class_Wide_Type (Typ) then
New_Disc := First_Discriminant (Root_Type (Typ));