* 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@72792
138bc75d-0d04-0410-961f-
82ee72b054a4
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>
(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;
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;
---------------------
-- --
-- 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- --
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;
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;
-- 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- --
(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
(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
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.
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.
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
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;
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 =>
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,
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
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;
-- 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;
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));
projects / platform / upstream / linaro-gcc.git / commitdiff