+2010-09-10 Vincent Celier <celier@adacore.com>
+
+ * vms_data.ads: Add new GNAT BIND qualifiers /32_MALLOC (for -H32) and
+ /64_MALLOC (for -H64).
+
+2010-09-10 Robert Dewar <dewar@adacore.com>
+
+ * errout.adb (Error_Msg_Internal): Test Parsing_Main_Subunit flag
+ (Error_Msg_NW): Test Parsing_Main_Subunit flag
+ * errout.ads (Parsing_Main_Subunit): New flag
+ * lib-load.adb (Load_Unit): Set Parsing_Main_Subunit flag
+ * par-ch6.adb: Minor style fix (remove redandant parentheses)
+ * par-ch9.adb: Minor style fix (remove redundant parens)
+ * par-load.adb: (Load): Deal with setting Parsing_Main_Subunit
+
+2010-09-10 Vincent Celier <celier@adacore.com>
+
+ * make.adb (Create_Binder_Mapping_File): Remove procedure. Replaced by
+ function of the same name in Makeutl.
+ (Gnatmake): Call function Create_Binder_Mapping_File in Makeutl, instead
+ of removed procedure when creating a binder mapping file.
+ * makeutl.adb (Create_Binder_Mapping_File): New function. Was a
+ procedure in Make.
+ * makeutl.ads (Create_Binder_Mapping_File): New function
+
2010-09-10 Jose Ruiz <ruiz@adacore.com>
* exp_cg.adb (Is_Predefined_Dispatching_Operation): Add the "__" scope
-- If the flag location is in the main extended source unit then for
-- sure we want the warning since it definitely belongs
- if In_Extended_Main_Source_Unit (Sptr) then
+ if Parsing_Main_Subunit
+ or else In_Extended_Main_Source_Unit (Sptr)
+ then
null;
-- If the flag location is not in the main extended source unit, then
is
begin
if Eflag
- and then In_Extended_Main_Source_Unit (N)
+ and then (Parsing_Main_Subunit
+ or else In_Extended_Main_Source_Unit (N))
and then Comes_From_Source (N)
then
Error_Msg_NEL (Msg, N, N, Sloc (N));
type Compiler_State_Type is (Parsing, Analyzing);
Compiler_State : Compiler_State_Type;
-- Indicates current state of compilation. This is put in the Errout spec
- -- because it affects the action of the error message handling. In
- -- particular, an attempt is made by Errout to suppress cascaded error
- -- messages in Parsing mode, but not in the other modes.
+ -- because it affects the handling of error messages. In particular, an
+ -- attempt is made by Errout to suppress cascaded error messages in Parsing
+ -- mode, but not in the other modes.
+
+ Parsing_Main_Subunit : Boolean := False;
+ -- Set True if we are currently parsing a subunit that is part of the main
+ -- extended source. We need this flag, since the In_Main_Extended_Source
+ -- test may produce an improper False value if called too early during the
+ -- parsing process. This is put in the Errout spec because it affects error
+ -- message handling. In particular, warnings and style messages during
+ -- parsing are only generated if this flag is set to True.
Current_Error_Source_File : Source_File_Index
renames Err_Vars.Current_Error_Source_File;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
-- See if we already have an entry for this unit
Unum := Main_Unit;
-
while Unum <= Units.Last loop
exit when Uname_Actual = Units.Table (Unum).Unit_Name;
Unum := Unum + 1;
-- Parse the new unit
declare
- Save_Index : constant Nat := Multiple_Unit_Index;
+ Save_Index : constant Nat := Multiple_Unit_Index;
+ Save_PMS : constant Boolean := Parsing_Main_Subunit;
+
begin
Multiple_Unit_Index := Get_Unit_Index (Uname_Actual);
Units.Table (Unum).Munit_Index := Multiple_Unit_Index;
Initialize_Scanner (Unum, Source_Index (Unum));
+
+ if Calling_Unit = Main_Unit and then Subunit then
+ Parsing_Main_Subunit := True;
+ end if;
+
Discard_List (Par (Configuration_Pragmas => False));
+
+ Parsing_Main_Subunit := Save_PMS;
+
Multiple_Unit_Index := Save_Index;
Set_Loading (Unum, False);
end;
-- Check that the main subprograms do exist and that they all
-- belong to the same project file.
- procedure Create_Binder_Mapping_File
- (Args : in out Argument_List; Last_Arg : in out Natural);
- -- Create a binder mapping file and add the necessary switch
-
-----------------
-- Check_Mains --
-----------------
end loop;
end Check_Mains;
- --------------------------------
- -- Create_Binder_Mapping_File --
- --------------------------------
-
- procedure Create_Binder_Mapping_File
- (Args : in out Argument_List; Last_Arg : in out Natural)
- is
- Mapping_FD : File_Descriptor := Invalid_FD;
- -- A File Descriptor for an eventual mapping file
-
- ALI_Unit : Unit_Name_Type := No_Unit_Name;
- -- The unit name of an ALI file
-
- ALI_Name : File_Name_Type := No_File;
- -- The file name of the ALI file
-
- ALI_Project : Project_Id := No_Project;
- -- The project of the ALI file
-
- Bytes : Integer;
- OK : Boolean := True;
- Unit : Unit_Index;
-
- Status : Boolean;
- -- For call to Close
-
- begin
- Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path);
- Record_Temp_File (Project_Tree, Mapping_Path);
-
- if Mapping_FD /= Invalid_FD then
-
- -- Traverse all units
-
- Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
-
- while Unit /= No_Unit_Index loop
- if Unit.Name /= No_Name then
-
- -- If there is a body, put it in the mapping
-
- if Unit.File_Names (Impl) /= No_Source
- and then Unit.File_Names (Impl).Project /=
- No_Project
- then
- Get_Name_String (Unit.Name);
- Add_Str_To_Name_Buffer ("%b");
- ALI_Unit := Name_Find;
- ALI_Name :=
- Lib_File_Name
- (Unit.File_Names (Impl).Display_File);
- ALI_Project := Unit.File_Names (Impl).Project;
-
- -- Otherwise, if there is a spec, put it in the mapping
-
- elsif Unit.File_Names (Spec) /= No_Source
- and then Unit.File_Names (Spec).Project /= No_Project
- then
- Get_Name_String (Unit.Name);
- Add_Str_To_Name_Buffer ("%s");
- ALI_Unit := Name_Find;
- ALI_Name :=
- Lib_File_Name
- (Unit.File_Names (Spec).Display_File);
- ALI_Project := Unit.File_Names (Spec).Project;
-
- else
- ALI_Name := No_File;
- end if;
-
- -- If we have something to put in the mapping then do it
- -- now. However, if the project is extended, we don't put
- -- anything in the mapping file, because we don't know where
- -- the ALI file is: it might be in the extended project
- -- object directory as well as in the extending project
- -- object directory.
-
- if ALI_Name /= No_File
- and then ALI_Project.Extended_By = No_Project
- and then ALI_Project.Extends = No_Project
- then
- -- First check if the ALI file exists. If it does not,
- -- do not put the unit in the mapping file.
-
- declare
- ALI : constant String := Get_Name_String (ALI_Name);
-
- begin
- -- For library projects, use the library directory,
- -- for other projects, use the object directory.
-
- if ALI_Project.Library then
- Get_Name_String (ALI_Project.Library_Dir.Name);
- else
- Get_Name_String
- (ALI_Project.Object_Directory.Display_Name);
- end if;
-
- if not
- Is_Directory_Separator (Name_Buffer (Name_Len))
- then
- Add_Char_To_Name_Buffer (Directory_Separator);
- end if;
-
- Add_Str_To_Name_Buffer (ALI);
- Add_Char_To_Name_Buffer (ASCII.LF);
-
- declare
- ALI_Path_Name : constant String :=
- Name_Buffer (1 .. Name_Len);
-
- begin
- if Is_Regular_File
- (ALI_Path_Name (1 .. ALI_Path_Name'Last - 1))
- then
- -- First line is the unit name
-
- Get_Name_String (ALI_Unit);
- Add_Char_To_Name_Buffer (ASCII.LF);
- Bytes :=
- Write
- (Mapping_FD,
- Name_Buffer (1)'Address,
- Name_Len);
- OK := Bytes = Name_Len;
-
- exit when not OK;
-
- -- Second line it the ALI file name
-
- Get_Name_String (ALI_Name);
- Add_Char_To_Name_Buffer (ASCII.LF);
- Bytes :=
- Write
- (Mapping_FD,
- Name_Buffer (1)'Address,
- Name_Len);
- OK := (Bytes = Name_Len);
-
- exit when not OK;
-
- -- Third line it the ALI path name
-
- Bytes :=
- Write
- (Mapping_FD,
- ALI_Path_Name (1)'Address,
- ALI_Path_Name'Length);
- OK := (Bytes = ALI_Path_Name'Length);
-
- -- If OK is False, it means we were unable to
- -- write a line. No point in continuing with the
- -- other units.
-
- exit when not OK;
- end if;
- end;
- end;
- end if;
- end if;
-
- Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
- end loop;
-
- Close (Mapping_FD, Status);
-
- OK := OK and Status;
-
- -- If the creation of the mapping file was successful, we add the
- -- switch to the arguments of gnatbind.
-
- if OK then
- Last_Arg := Last_Arg + 1;
- Args (Last_Arg) :=
- new String'("-F=" & Get_Name_String (Mapping_Path));
- end if;
- end if;
- end Create_Binder_Mapping_File;
-
-- Start of processing for Gnatmake
-- This body is very long, should be broken down???
-- If switch -C was specified, create a binder mapping file
if Create_Mapping_File then
- Create_Binder_Mapping_File (Args, Last_Arg);
+ Mapping_Path := Create_Binder_Mapping_File;
+
+ if Mapping_Path /= No_Path then
+ Last_Arg := Last_Arg + 1;
+ Args (Last_Arg) :=
+ new String'("-F=" & Get_Name_String (Mapping_Path));
+ end if;
end if;
end if;
with Prj.Util;
with Snames; use Snames;
with Table;
+with Tempdir;
with Ada.Command_Line; use Ada.Command_Line;
return True;
end Check_Source_Info_In_ALI;
+ --------------------------------
+ -- Create_Binder_Mapping_File --
+ --------------------------------
+
+ function Create_Binder_Mapping_File return Path_Name_Type is
+ Mapping_Path : Path_Name_Type := No_Path;
+
+ Mapping_FD : File_Descriptor := Invalid_FD;
+ -- A File Descriptor for an eventual mapping file
+
+ ALI_Unit : Unit_Name_Type := No_Unit_Name;
+ -- The unit name of an ALI file
+
+ ALI_Name : File_Name_Type := No_File;
+ -- The file name of the ALI file
+
+ ALI_Project : Project_Id := No_Project;
+ -- The project of the ALI file
+
+ Bytes : Integer;
+ OK : Boolean := False;
+ Unit : Unit_Index;
+
+ Status : Boolean;
+ -- For call to Close
+
+ begin
+ Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path);
+ Record_Temp_File (Project_Tree, Mapping_Path);
+
+ if Mapping_FD /= Invalid_FD then
+ OK := True;
+
+ -- Traverse all units
+
+ Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
+ while Unit /= No_Unit_Index loop
+ if Unit.Name /= No_Name then
+
+ -- If there is a body, put it in the mapping
+
+ if Unit.File_Names (Impl) /= No_Source
+ and then Unit.File_Names (Impl).Project /= No_Project
+ then
+ Get_Name_String (Unit.Name);
+ Add_Str_To_Name_Buffer ("%b");
+ ALI_Unit := Name_Find;
+ ALI_Name :=
+ Lib_File_Name (Unit.File_Names (Impl).Display_File);
+ ALI_Project := Unit.File_Names (Impl).Project;
+
+ -- Otherwise, if there is a spec, put it in the mapping
+
+ elsif Unit.File_Names (Spec) /= No_Source
+ and then Unit.File_Names (Spec).Project /= No_Project
+ then
+ Get_Name_String (Unit.Name);
+ Add_Str_To_Name_Buffer ("%s");
+ ALI_Unit := Name_Find;
+ ALI_Name :=
+ Lib_File_Name (Unit.File_Names (Spec).Display_File);
+ ALI_Project := Unit.File_Names (Spec).Project;
+
+ else
+ ALI_Name := No_File;
+ end if;
+
+ -- If we have something to put in the mapping then do it now.
+ -- However, if the project is extended, we don't put anything
+ -- in the mapping file, since we don't know where the ALI file
+ -- is: it might be in the extended project object directory as
+ -- well as in the extending project object directory.
+
+ if ALI_Name /= No_File
+ and then ALI_Project.Extended_By = No_Project
+ and then ALI_Project.Extends = No_Project
+ then
+ -- First check if the ALI file exists. If it does not, do
+ -- not put the unit in the mapping file.
+
+ declare
+ ALI : constant String := Get_Name_String (ALI_Name);
+
+ begin
+ -- For library projects, use the library ALI directory,
+ -- for other projects, use the object directory.
+
+ if ALI_Project.Library then
+ Get_Name_String
+ (ALI_Project.Library_ALI_Dir.Display_Name);
+ else
+ Get_Name_String
+ (ALI_Project.Object_Directory.Display_Name);
+ end if;
+
+ if not
+ Is_Directory_Separator (Name_Buffer (Name_Len))
+ then
+ Add_Char_To_Name_Buffer (Directory_Separator);
+ end if;
+
+ Add_Str_To_Name_Buffer (ALI);
+ Add_Char_To_Name_Buffer (ASCII.LF);
+
+ declare
+ ALI_Path_Name : constant String :=
+ Name_Buffer (1 .. Name_Len);
+
+ begin
+ if Is_Regular_File
+ (ALI_Path_Name (1 .. ALI_Path_Name'Last - 1))
+ then
+ -- First line is the unit name
+
+ Get_Name_String (ALI_Unit);
+ Add_Char_To_Name_Buffer (ASCII.LF);
+ Bytes :=
+ Write
+ (Mapping_FD,
+ Name_Buffer (1)'Address,
+ Name_Len);
+ OK := Bytes = Name_Len;
+
+ exit when not OK;
+
+ -- Second line it the ALI file name
+
+ Get_Name_String (ALI_Name);
+ Add_Char_To_Name_Buffer (ASCII.LF);
+ Bytes :=
+ Write
+ (Mapping_FD,
+ Name_Buffer (1)'Address,
+ Name_Len);
+ OK := (Bytes = Name_Len);
+
+ exit when not OK;
+
+ -- Third line it the ALI path name
+
+ Bytes :=
+ Write
+ (Mapping_FD,
+ ALI_Path_Name (1)'Address,
+ ALI_Path_Name'Length);
+ OK := (Bytes = ALI_Path_Name'Length);
+
+ -- If OK is False, it means we were unable to
+ -- write a line. No point in continuing with the
+ -- other units.
+
+ exit when not OK;
+ end if;
+ end;
+ end;
+ end if;
+ end if;
+
+ Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
+ end loop;
+
+ Close (Mapping_FD, Status);
+
+ OK := OK and Status;
+ end if;
+
+ -- If the creation of the mapping file was successful, we add the switch
+ -- to the arguments of gnatbind.
+
+ if OK then
+ return Mapping_Path;
+
+ else
+ return No_Path;
+ end if;
+ end Create_Binder_Mapping_File;
+
-----------------
-- Create_Name --
-----------------
Last : in out Natural);
-- Add a string to a list of strings
+ function Create_Binder_Mapping_File return Path_Name_Type;
+ -- Create a binder mapping file and returns its path name
+
function Create_Name (Name : String) return File_Name_Type;
function Create_Name (Name : String) return Name_Id;
function Create_Name (Name : String) return Path_Name_Type;
Is_Overriding := True;
end if;
- if (Is_Overriding or else Not_Overriding) then
+ if Is_Overriding or else Not_Overriding then
-- Note that if we are not in Ada_05 mode, error messages have
-- already been given, so no need to give another message here.
Is_Overriding := True;
end if;
- if (Is_Overriding or else Not_Overriding) then
+ if Is_Overriding or else Not_Overriding then
if Ada_Version < Ada_05 then
Error_Msg_SP ("overriding indicator is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
Is_Overriding := True;
end if;
- if (Is_Overriding or else Not_Overriding) then
+ if Is_Overriding or else Not_Overriding then
if Ada_Version < Ada_05 then
Error_Msg_SP ("overriding indicator is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
Error_Node => Curunit,
Corr_Body => Cur_Unum);
- -- If we successfully load the unit, then set the spec/body
- -- pointers. Once again note that if the loaded unit has a fatal error,
- -- Load will have set our Fatal_Error flag to propagate this condition.
+ -- If we successfully load the unit, then set the spec/body pointers.
+ -- Once again note that if the loaded unit has a fatal error, Load will
+ -- have set our Fatal_Error flag to propagate this condition.
if Unum /= No_Unit then
Set_Library_Unit (Curunit, Cunit (Unum));
-- If current unit is a subunit, then load its parent body
elsif Nkind (Unit (Curunit)) = N_Subunit then
- Body_Name := Get_Parent_Body_Name (Unit_Name (Cur_Unum));
- Unum :=
- Load_Unit
- (Load_Name => Body_Name,
- Required => True,
- Subunit => True,
- Error_Node => Name (Unit (Curunit)));
+ declare
+ Save_PMS : constant Boolean := Parsing_Main_Subunit;
- if Unum /= No_Unit then
- Set_Library_Unit (Curunit, Cunit (Unum));
- end if;
+ begin
+ Parsing_Main_Subunit := False;
+ Body_Name := Get_Parent_Body_Name (Unit_Name (Cur_Unum));
+ Unum :=
+ Load_Unit
+ (Load_Name => Body_Name,
+ Required => True,
+ Subunit => False,
+ Error_Node => Name (Unit (Curunit)));
+
+ if Unum /= No_Unit then
+ Set_Library_Unit (Curunit, Cunit (Unum));
+ end if;
+
+ Parsing_Main_Subunit := Save_PMS;
+ end;
end if;
-- Now we load with'ed units, with style/validity checks turned off
--
-- The main program is not in Ada.
+ S_Bind_Alloc32 : aliased constant S := "/32_MALLOC " &
+ "-H32";
+ -- /32_MALLOC
+ --
+ -- Use 32-bit allocations for `__gnat_malloc' (and thus for
+ -- access types).
+
+ S_Bind_Alloc64 : aliased constant S := "/64_MALLOC " &
+ "-H64";
+ -- /64_MALLOC
+ --
+ -- Use 64-bit allocations for `__gnat_malloc' (and thus for
+ -- access types).
+
S_Bind_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
"DEFAULT " &
"-vP0 " &
S_Bind_Library 'Access,
S_Bind_Linker 'Access,
S_Bind_Main 'Access,
+ S_Bind_Alloc32 'Access,
+ S_Bind_Alloc64 'Access,
S_Bind_Mess 'Access,
S_Bind_Nostinc 'Access,
S_Bind_Nostlib 'Access,
OSDN Git Service
