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

gcc/ada/ChangeLog

 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>
 

gcc/ada/exp_ch3.adb

@@ -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;
 
       ---------------------

gcc/ada/exp_prag.adb

@@ -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;

gcc/ada/g-regpat.adb

@@ -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;

gcc/ada/g-regpat.ads

@@ -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.

gcc/ada/gnat_wrapper.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         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;

gcc/ada/sem_ch12.adb

@@ -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

gcc/ada/sem_ch3.adb

@@ -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;

gcc/ada/sem_elab.adb

@@ -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;
 

gcc/ada/sem_util.adb

@@ -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));