-- This is the VxWorks AE 653 version of this procedure
separate (System.Threads.Initialization)
-
procedure Initialize_Task_Hooks is
- -- When defining the following routines for export in an AE 1.1
+ -- When defining the following routine for export in an AE 1.1
-- simulation of AE653, Interfaces.C.int may be used for the
-- parameters of FUNCPTR.
type FUNCPTR is access function (T : OSI.Thread_Id) return OSI.STATUS;
pragma Import (C, procCreateHookAdd, "procCreateHookAdd");
-- Registers task registration routine for AE653
- procedure procStartHookAdd (StartHookFunction : FUNCPTR);
- pragma Import (C, procStartHookAdd, "procStartHookAdd");
- -- Registers task restart routine for AE653
-
- Result : OSI.STATUS;
begin
- -- Register the exported routines with the vThreads ARINC API
+ -- Register the exported routine with the vThreads ARINC API
procCreateHookAdd (Register'Access);
- procStartHookAdd (Reset_TSD'Access);
- -- Register the environment task
- Result := Register (OSI.taskIdSelf);
- pragma Assert (Result /= -1);
end Initialize_Task_Hooks;
-- Common procedure that is executed when a SIGFPE, SIGILL,
-- SIGSEGV, or SIGBUS is captured.
- procedure Install_Handler;
- pragma Export (C, Install_Handler, "__gnat_install_handler");
- -- Install handler for the synchronous signals. The C profile
- -- here is what is expected by the binder-generated main.
-
------------------------
-- GNAT_Error_Handler --
------------------------
end if;
end Set_Globals;
- -----------------------------
- -- Install_Signal_Handlers --
- -----------------------------
-
- function Install_Signal_Handlers return Interfaces.C.int is
- begin
- Install_Handler;
- return 0;
- end Install_Signal_Handlers;
-
---------------------
-- Install_Handler --
---------------------
-- the task hook libraries should be included in the VxWorks kernel.
with System.Secondary_Stack;
+with System.Storage_Elements;
with Interfaces.C;
with Unchecked_Conversion;
--------------
function Register (T : OSI.Thread_Id) return OSI.STATUS is
- TSD : ATSD_Access := new ATSD;
Result : OSI.STATUS;
begin
-- It cannot be assumed that the caller of this routine has a ATSD;
-- so neither this procedure nor the procedures that it calls should
- -- raise or handle exceptions, or make use of a secondary stack.
+ -- raise or handle exceptions, or make use of a secondary stack.
+
+ -- This routine is only necessary because taskVarAdd cannot be
+ -- executed once an AE653 partition has entered normal mode
+ -- (depending on configRecord.c, allocation could be disabled).
+ -- Otherwise, everything could have been done in Thread_Body_Enter.
if OSI.taskIdVerify (T) = OSI.ERROR
or else OSI.taskVarGet (T, Current_ATSD'Access) /= OSI.ERROR
end if;
Result := OSI.taskVarAdd (T, Current_ATSD'Access);
- pragma Assert (Result /= -1);
- Result := OSI.taskVarSet (T, Current_ATSD'Access, TSD.all'Address);
- pragma Assert (Result /= -1);
- TSD.Sec_Stack_Addr := SSS.SS_Create;
- SSS.SS_Init (TSD.Sec_Stack_Addr);
+ pragma Assert (Result /= OSI.ERROR);
+
return Result;
end Register;
- ---------------
- -- Reset_TSD --
- ---------------
+ subtype Default_Sec_Stack is
+ System.Storage_Elements.Storage_Array
+ (1 .. SSS.Default_Secondary_Stack_Size);
- function Reset_TSD (T : OSI.Thread_Id) return OSI.STATUS is
- TSD_Ptr : int;
- function To_Address is new Unchecked_Conversion
- (Interfaces.C.int, ATSD_Access);
- begin
- TSD_Ptr := OSI.taskVarGet (T, Current_ATSD'Access);
- pragma Assert (TSD_Ptr /= OSI.ERROR);
+ Main_Sec_Stack : aliased Default_Sec_Stack;
- -- Just reset the secondary stack pointer. The implementation here
- -- assumes that the fixed secondary stack implementation is used.
- -- If not, there will be a memory leak (along with allocation, which
- -- is prohibited for ARINC processes once the system enters "normal"
- -- mode).
+ -- Secondary stack for environment task
- SSS.SS_Init (To_Address (TSD_Ptr).Sec_Stack_Addr);
- return OSI.OK;
- end Reset_TSD;
+ Main_ATSD : aliased ATSD;
+
+ -- TSD for environment task
begin
Initialize_Task_Hooks;
+
+ -- Register the environment task
+ declare
+ Result : Interfaces.C.int := Register (OSI.taskIdSelf);
+ pragma Assert (Result /= OSI.ERROR);
+ begin
+ Thread_Body_Enter
+ (Main_Sec_Stack'Address,
+ Main_Sec_Stack'Size / System.Storage_Unit,
+ Main_ATSD'Address);
+ end;
end System.Threads.Initialization;
terminated by a directory separator except if just after a drive name. */
int name_len = strlen (name);
char last_char = name[name_len - 1];
- char win32_name[4096];
+ char win32_name[GNAT_MAX_PATH_LEN + 2];
+
+ if (name_len > GNAT_MAX_PATH_LEN)
+ return -1;
strcpy (win32_name, name);
---------------------
procedure Gen_Output_File (Filename : String) is
- Public_Version : constant Boolean := Gnat_Version_Type = "PUBLIC ";
- -- Set true if this is the public version of GNAT
-
+ Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
begin
-- Acquire settings for Interrupt_State pragmas
-- Get the time stamp of the former bind for public version warning
- if Public_Version then
+ if Is_Public_Version then
Record_Time_From_Last_Bind;
end if;
-- Periodically issue a warning when the public version is used on
-- big projects
- if Public_Version then
+ if Is_Public_Version then
Public_Version_Warning;
end if;
end Gen_Output_File;
-- Include some utility functions and saved all reserved
-- env. vars. by including Makefile.prolog.
+ New_Line;
+
+ -- First, if MAKE_ROOT is not defined, try to get GNAT prefix
+
+ Put (" ifeq ($(");
+ Put (MAKE_ROOT);
+ Put ("),)");
+ New_Line;
+
+ Put (" MAKE_ROOT=$(shell gprcmd prefix)");
+ New_Line;
+
+ Put (" endif");
+ New_Line;
+
+ New_Line;
+
+ -- If MAKE_ROOT is still not defined, then fail
+
Put (" ifeq ($(");
Put (MAKE_ROOT);
Put ("),)");
-- the FSF version of GNAT, but there are specializations for
-- the GNATPRO and Public releases by Ada Core Technologies.
- Public_Version : constant Boolean := Gnat_Version_Type = "PUBLIC ";
- -- Set True for the public version of GNAT
-
- GNATPRO_Version : constant Boolean := Gnat_Version_Type = "GNATPRO";
- -- Set True for the GNATPRO version of GNAT
-
procedure End_Line;
-- Add blanks up to column 76, and then a final vertical bar
Write_Eol;
end End_Line;
+ Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
+ Is_FSF_Version : constant Boolean := Get_Gnat_Build_Type = FSF;
+
-- Start of processing for Compiler_Abort
begin
-- Otherwise we use the standard fixed text
else
- if Public_Version or GNATPRO_Version then
+ if Is_FSF_Version then
+ Write_Str
+ ("| Please submit a bug report; see" &
+ " http://gcc.gnu.org/bugs.html.");
+ End_Line;
+
+ else
Write_Str
("| Please submit bug report by email " &
"to report@gnat.com.");
("| Use a subject line meaningful to you" &
" and us to track the bug.");
End_Line;
-
- else
- Write_Str
- ("| Please submit a bug report; see" &
- " http://gcc.gnu.org/bugs.html.");
- End_Line;
end if;
- if GNATPRO_Version then
+ if not (Is_Public_Version and Is_FSF_Version) then
Write_Str
("| (include your customer number #nnn " &
"in the subject line).");
("| (concatenated together with no headers between files).");
End_Line;
- if Public_Version then
+ if Is_Public_Version then
Write_Str
("| (use plain ASCII or MIME attachment).");
End_Line;
"for submitting bugs.");
End_Line;
- elsif GNATPRO_Version then
+ elsif not Is_FSF_Version then
Write_Str
("| (use plain ASCII or MIME attachment, or FTP "
& "to your customer directory).");
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
+with Output; use Output;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
return Entity_Id;
-- Builds a new entity for Standard
+ procedure Print_Standard;
+ -- Print representation of package Standard if switch set
+
procedure Set_Integer_Bounds
(Id : Entity_Id;
Typ : Entity_Id;
-- The Error node has an Etype of Any_Type to help error recovery
Set_Etype (Error, Any_Type);
+
+ -- Print representation of standard if switch set
+
+ if Opt.Print_Standard then
+ Print_Standard;
+ end if;
end Create_Standard;
------------------------------------
return E;
end New_Standard_Entity;
+ --------------------
+ -- Print_Standard --
+ --------------------
+
+ procedure Print_Standard is
+
+ procedure P (Item : String) renames Output.Write_Line;
+ -- Short-hand, since we do a lot of line writes here!
+
+ procedure P_Int_Range (Size : Pos);
+ -- Prints the range of an integer based on its Size
+
+ procedure P_Float_Range (Id : Entity_Id);
+ -- Prints the bounds range for the given float type entity
+
+ -------------------
+ -- P_Float_Range --
+ -------------------
+
+ procedure P_Float_Range (Id : Entity_Id) is
+ Digs : constant Nat := UI_To_Int (Digits_Value (Id));
+
+ begin
+ Write_Str (" range ");
+
+ if Vax_Float (Id) then
+ if Digs = VAXFF_Digits then
+ Write_Str (VAXFF_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (VAXFF_Last'Universal_Literal_String);
+
+ elsif Digs = VAXDF_Digits then
+ Write_Str (VAXDF_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (VAXDF_Last'Universal_Literal_String);
+
+ else
+ pragma Assert (Digs = VAXGF_Digits);
+
+ Write_Str (VAXGF_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (VAXGF_Last'Universal_Literal_String);
+ end if;
+
+ elsif Is_AAMP_Float (Id) then
+ if Digs = AAMPS_Digits then
+ Write_Str (AAMPS_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (AAMPS_Last'Universal_Literal_String);
+
+ else
+ pragma Assert (Digs = AAMPL_Digits);
+ Write_Str (AAMPL_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (AAMPL_Last'Universal_Literal_String);
+ end if;
+
+ elsif Digs = IEEES_Digits then
+ Write_Str (IEEES_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (IEEES_Last'Universal_Literal_String);
+
+
+ elsif Digs = IEEEL_Digits then
+ Write_Str (IEEEL_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (IEEEL_Last'Universal_Literal_String);
+
+ else
+ pragma Assert (Digs = IEEEX_Digits);
+
+ Write_Str (IEEEX_First'Universal_Literal_String);
+ Write_Str (" .. ");
+ Write_Str (IEEEX_Last'Universal_Literal_String);
+ end if;
+
+ Write_Str (";");
+ Write_Eol;
+ end P_Float_Range;
+
+ -----------------
+ -- P_Int_Range --
+ -----------------
+
+ procedure P_Int_Range (Size : Pos) is
+ begin
+ Write_Str (" is range -(2 **");
+ Write_Int (Size - 1);
+ Write_Str (")");
+ Write_Str (" .. +(2 **");
+ Write_Int (Size - 1);
+ Write_Str (" - 1);");
+ Write_Eol;
+ end P_Int_Range;
+
+ -- Start of processing for Print_Standard
+
+ begin
+ P ("-- Representation of package Standard");
+ Write_Eol;
+ P ("-- This is not accurate Ada, since new base types cannot be ");
+ P ("-- created, but the listing shows the target dependent");
+ P ("-- characteristics of the Standard types for this compiler");
+ Write_Eol;
+
+ P ("package Standard is");
+ P ("pragma Pure(Standard);");
+ Write_Eol;
+
+ P (" type Boolean is (False, True);");
+ P (" for Boolean'Size use 1;");
+ P (" for Boolean use (False => 0, True => 1);");
+ Write_Eol;
+
+ -- Integer types
+
+ Write_Str (" type Integer");
+ P_Int_Range (Standard_Integer_Size);
+ Write_Str (" for Integer'Size use ");
+ Write_Int (Standard_Integer_Size);
+ P (";");
+ Write_Eol;
+
+ P (" subtype Natural is Integer range 0 .. Integer'Last;");
+ P (" subtype Positive is Integer range 1 .. Integer'Last;");
+ Write_Eol;
+
+ Write_Str (" type Short_Short_Integer");
+ P_Int_Range (Standard_Short_Short_Integer_Size);
+ Write_Str (" for Short_Short_Integer'Size use ");
+ Write_Int (Standard_Short_Short_Integer_Size);
+ P (";");
+ Write_Eol;
+
+ Write_Str (" type Short_Integer");
+ P_Int_Range (Standard_Short_Integer_Size);
+ Write_Str (" for Short_Integer'Size use ");
+ Write_Int (Standard_Short_Integer_Size);
+ P (";");
+ Write_Eol;
+
+ Write_Str (" type Long_Integer");
+ P_Int_Range (Standard_Long_Integer_Size);
+ Write_Str (" for Long_Integer'Size use ");
+ Write_Int (Standard_Long_Integer_Size);
+ P (";");
+ Write_Eol;
+
+ Write_Str (" type Long_Long_Integer");
+ P_Int_Range (Standard_Long_Long_Integer_Size);
+ Write_Str (" for Long_Long_Integer'Size use ");
+ Write_Int (Standard_Long_Long_Integer_Size);
+ P (";");
+ Write_Eol;
+
+ -- Floating point types
+
+ Write_Str (" type Short_Float is digits ");
+ Write_Int (Standard_Short_Float_Digits);
+ Write_Eol;
+ P_Float_Range (Standard_Short_Float);
+ Write_Str (" for Short_Float'Size use ");
+ Write_Int (Standard_Short_Float_Size);
+ P (";");
+ Write_Eol;
+
+ Write_Str (" type Float is digits ");
+ Write_Int (Standard_Float_Digits);
+ Write_Eol;
+ P_Float_Range (Standard_Float);
+ Write_Str (" for Float'Size use ");
+ Write_Int (Standard_Float_Size);
+ P (";");
+ Write_Eol;
+
+ Write_Str (" type Long_Float is digits ");
+ Write_Int (Standard_Long_Float_Digits);
+ Write_Eol;
+ P_Float_Range (Standard_Long_Float);
+ Write_Str (" for Long_Float'Size use ");
+ Write_Int (Standard_Long_Float_Size);
+ P (";");
+ Write_Eol;
+
+ Write_Str (" type Long_Long_Float is digits ");
+ Write_Int (Standard_Long_Long_Float_Digits);
+ Write_Eol;
+ P_Float_Range (Standard_Long_Long_Float);
+ Write_Str (" for Long_Long_Float'Size use ");
+ Write_Int (Standard_Long_Long_Float_Size);
+ P (";");
+ Write_Eol;
+
+ P (" type Character is (...)");
+ Write_Str (" for Character'Size use ");
+ Write_Int (Standard_Character_Size);
+ P (";");
+ P (" -- See RM A.1(35) for details of this type");
+ Write_Eol;
+
+ P (" type Wide_Character is (...)");
+ Write_Str (" for Wide_Character'Size use ");
+ Write_Int (Standard_Wide_Character_Size);
+ P (";");
+ P (" -- See RM A.1(36) for details of this type");
+ Write_Eol;
+
+ P (" type String is array (Positive range <>) of Character;");
+ P (" pragma Pack (String);");
+ Write_Eol;
+
+ P (" type Wide_String is array (Positive range <>)" &
+ " of Wide_Character;");
+ P (" pragma Pack (Wide_String);");
+ Write_Eol;
+
+ -- Here it's OK to use the Duration type of the host compiler since
+ -- the implementation of Duration in GNAT is target independent.
+
+ if Duration_32_Bits_On_Target then
+ P (" type Duration is delta 0.020");
+ P (" range -((2 ** 31 - 1) * 0.020) ..");
+ P (" +((2 ** 31 - 1) * 0.020);");
+ P (" for Duration'Small use 0.020;");
+ else
+ P (" type Duration is delta 0.000000001");
+ P (" range -((2 ** 63 - 1) * 0.000000001) ..");
+ P (" +((2 ** 63 - 1) * 0.000000001);");
+ P (" for Duration'Small use 0.000000001;");
+ end if;
+
+ Write_Eol;
+
+ P (" Constraint_Error : exception;");
+ P (" Program_Error : exception;");
+ P (" Storage_Error : exception;");
+ P (" Tasking_Error : exception;");
+ P (" Numeric_Error : exception renames Constraint_Error;");
+ Write_Eol;
+
+ P ("end Standard;");
+ end Print_Standard;
+
----------------------
-- Set_Float_Bounds --
----------------------
-- dz Print source of package Standard. Normally the source print out
-- does not include package Standard, even if the -df switch is set.
-- This switch forces output of the source recreated from the internal
- -- tree built for Standard.
+ -- tree built for Standard. Note that this differs from -gnatS in
+ -- that it prints from the actual tree using the normal Sprint
+ -- circuitry for printing trees.
-- dA Forces output of representation information, including full
-- information for all internal type and object entities, as well
-- the record that is the fat pointer representation of an RAST.
-- Esize (Uint12)
--- Present in all types and subtypes, an also for components, constants,
+-- Present in all types and subtypes, and also for components, constants,
-- and variables. Contains the Object_Size of the type or of the object.
-- A value of zero indicates that the value is not yet known.
--
-- Present in all type and subtype entities. Contains the value of
-- type'Size as defined in the RM. See also the Esize field and
-- and the description on "Handling of Type'Size Values". A value
--- of zero for in this field for a non-discrete type means that
+-- of zero in this field for a non-discrete type means that
-- the front end has not yet determined the size value. For the
-- case of a discrete type, this field is always set by the front
-- end and zero is a legitimate value for a type with one value.
Excep_Handlers : List_Id;
begin
+ New_Scope (Spec_Id);
+
-- Get proper setting for secondary stack size
if List_Length (Pragma_Argument_Associations (TB_Pragma)) = 2 then
Exception_Handlers => Excep_Handlers));
Analyze (Handled_Statement_Sequence (N));
+ End_Scope;
end Expand_Thread_Body;
-- Start of processing for Expand_N_Subprogram_Body
with Sem_Ch8;
with Sem_Ch12;
with Sem_Ch13;
+with Sem_Elim;
with Sem_Eval;
with Sem_Type;
with Sinfo; use Sinfo;
Sem_Ch8.Initialize;
Sem_Ch12.Initialize;
Sem_Ch13.Initialize;
+ Sem_Elim.Initialize;
Sem_Eval.Initialize;
Sem_Type.Init_Interp_Tables;
-- check for the nul character in Gnat_Version_String.
pragma Import (C, Version_String, "version_string");
+ -------------------------
+ -- Get_Gnat_Build_Type --
+ -------------------------
+
+ function Get_Gnat_Build_Type return Gnat_Build_Type is
+ begin
+ return FSF;
+ end Get_Gnat_Build_Type;
+
-------------------------
-- Gnat_Version_String --
-------------------------
-- Static string identifying this version, that can be used as an argument
-- to e.g. pragma Ident.
- Gnat_Version_Type : constant String := "FSF ";
- -- GNAT FSF version. This version of GNAT is part of a Free Software
- -- Foundation release of the GNU Compiler Collection (GCC). The binder
- -- will not output informational messages regarding intended use,
- -- and the bug box generated by Comperr will give information on
- -- how to report bugs and list the "no warranty" information.
+ type Gnat_Build_Type is (FSF, Public);
+ -- See Get_Gnat_Build_Type below for the meaning of these values.
+
+ function Get_Gnat_Build_Type return Gnat_Build_Type;
+ -- This function returns one of the following values of Gnat_Build_Type:
+ --
+ -- FSF
+ -- GNAT FSF version. This version of GNAT is part of a Free Software
+ -- Foundation release of the GNU Compiler Collection (GCC). The binder
+ -- will not output informational messages regarding intended use,
+ -- and the bug box generated by Comperr will give information on
+ -- how to report bugs and list the "no warranty" information.
+ --
+ -- Public
+ -- GNAT Public version.
+ -- The binder will output informational messages, and the bug box
+ -- generated by the package Comperr will give appropriate bug
+ -- submission instructions.
Ver_Len_Max : constant := 32;
-- Longest possible length for Gnat_Version_String in this or any
-- extend handle recursive directories ("/**" notation)
-- deps post process dependency makefiles
-- stamp copy file time stamp from file1 to file2
+-- prefix get the prefix of the GNAT installation
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Regpat; use GNAT.Regpat;
with Gnatvsn;
+with Osint; use Osint;
+with Namet; use Namet;
procedure Gprcmd is
elsif Cmd = "stamp" then
Check_Args (Argument_Count = 3);
Copy_Time_Stamp (Argument (2), Argument (3));
+
+ elsif Cmd = "prefix" then
+
+ -- Find the GNAT prefix. gprcmd is found in <prefix>/bin.
+ -- So we find the full path of gprcmd, verify that it is in a
+ -- subdirectory "bin", and return the <prefix> if it is the case.
+ -- Otherwise, nothing is returned.
+
+ Find_Program_Name;
+
+ declare
+ Path : String_Access :=
+ Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
+ Index : Natural;
+
+ begin
+ if Path /= null then
+ Index := Path'Last;
+
+ while Index >= Path'First + 4 loop
+ exit when Path (Index) = Directory_Separator;
+ Index := Index - 1;
+ end loop;
+
+ if Index > Path'First + 5
+ and then Path (Index - 3 .. Index - 1) = "bin"
+ and then Path (Index - 4) = Directory_Separator
+ then
+ -- We have found the <prefix>, return it.
+
+ Put (Path (Path'First .. Index - 5));
+ end if;
+ end if;
+ end;
end if;
end;
end Gprcmd;
is
Unum : Unit_Number_Type;
Cunit_Entity : Entity_Id;
- Scope_Entity : Entity_Id;
Cunit : Node_Id;
Du_Name : Node_Or_Entity_Id;
End_Lab : Node_Id;
Du_Name := Cunit_Entity;
End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location);
- Scope_Entity := Standard_Standard;
-
-- Child package
- else -- Nkind (Name (With_Node)) = N_Expanded_Name
+ else
+
+ -- Nkind (Name (With_Node)) = N_Expanded_Name
+
Cunit_Entity :=
Make_Defining_Identifier (No_Location,
Chars => Chars (Selector_Name (Name (With_Node))));
Set_Is_Child_Unit (Cunit_Entity);
- if Nkind (Du_Name) = N_Defining_Program_Unit_Name then
- Scope_Entity := Defining_Identifier (Du_Name);
- else
- Scope_Entity := Du_Name;
- end if;
-
End_Lab :=
Make_Designator (No_Location,
Name => New_Copy_Tree (Prefix (Name (With_Node))),
Identifier => New_Occurrence_Of (Cunit_Entity, No_Location));
+
end if;
- Set_Scope (Cunit_Entity, Scope_Entity);
+ Set_Scope (Cunit_Entity, Standard_Standard);
Cunit :=
Make_Compilation_Unit (No_Location,
end Generic_Separately_Compiled;
function Generic_Separately_Compiled
- (Sfile : File_Name_Type)
- return Boolean
+ (Sfile : File_Name_Type) return Boolean
is
begin
-- Exactly the same as previous function, but works directly on a file
----------------------------------
function Get_Cunit_Entity_Unit_Number
- (E : Entity_Id)
- return Unit_Number_Type
+ (E : Entity_Id) return Unit_Number_Type
is
begin
for U in Units.First .. Units.Last loop
--------------------------------
function In_Extended_Main_Code_Unit
- (N : Node_Or_Entity_Id)
- return Boolean
+ (N : Node_Or_Entity_Id) return Boolean
is
begin
if Sloc (N) = Standard_Location then
end if;
end In_Extended_Main_Code_Unit;
- function In_Extended_Main_Code_Unit
- (Loc : Source_Ptr)
- return Boolean
- is
+ function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean is
begin
if Loc = Standard_Location then
return True;
----------------------------------
function In_Extended_Main_Source_Unit
- (N : Node_Or_Entity_Id)
- return Boolean
+ (N : Node_Or_Entity_Id) return Boolean
is
Nloc : constant Source_Ptr := Sloc (N);
Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
end In_Extended_Main_Source_Unit;
function In_Extended_Main_Source_Unit
- (Loc : Source_Ptr)
- return Boolean
+ (Loc : Source_Ptr) return Boolean
is
Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
-- and False otherwise.
function In_Extended_Main_Code_Unit
- (N : Node_Or_Entity_Id)
- return Boolean;
+ (N : Node_Or_Entity_Id) return Boolean;
-- Return True if the node is in the generated code of the extended main
-- unit, defined as the main unit, its specification (if any), and all
-- its subunits (considered recursively). Units for which this enquiry
-- If the main unit is itself a subunit, then the extended main unit
-- includes its parent unit, and the parent unit spec if it is separate.
- function In_Extended_Main_Code_Unit
- (Loc : Source_Ptr)
- return Boolean;
+ function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean;
-- Same function as above, but argument is a source pointer rather
-- than a node.
function In_Extended_Main_Source_Unit
- (N : Node_Or_Entity_Id)
- return Boolean;
+ (N : Node_Or_Entity_Id) return Boolean;
-- Return True if the node is in the source text of the extended main
-- unit, defined as the main unit, its specification (if any), and all
-- its subunits (considered recursively). Units for which this enquiry
-- a subunit, then the extended main unit includes its parent unit,
-- and the parent unit spec if it is separate.
- function In_Extended_Main_Source_Unit
- (Loc : Source_Ptr)
- return Boolean;
+ function In_Extended_Main_Source_Unit (Loc : Source_Ptr) return Boolean;
-- Same function as above, but argument is a source pointer rather
-- than a node.
-- could not have been built without making a unit table entry.
function Get_Cunit_Entity_Unit_Number
- (E : Entity_Id)
- return Unit_Number_Type;
+ (E : Entity_Id) return Unit_Number_Type;
-- Return unit number of the unit whose compilation unit spec entity is
-- the one passed as an argument. This must always succeed since the
-- entity could not have been built without making a unit table entry.
-- compiled with the current approach.
function Generic_Separately_Compiled
- (Sfile : File_Name_Type)
- return Boolean;
+ (Sfile : File_Name_Type) return Boolean;
-- Same as the previous function, but works directly on a unit file name.
private
end loop Look_For_Foreign;
end if;
- -- The, find all mains, or if there is a foreign
+ -- Then, find all mains, or if there is a foreign
-- language, all the Ada mains.
while Value /= Prj.Nil_String loop
-- linking with all standard library files.
Opt.No_Stdlib := True;
+
+ Add_Switch (Argv, Compiler, And_Save => And_Save);
Add_Switch (Argv, Binder, And_Save => And_Save);
elsif Argv (2 .. Argv'Last) = "nostdinc" then
- -- Pass -nostdinv to the Compiler and to gnatbind
+ -- Pass -nostdinc to the Compiler and to gnatbind
Opt.No_Stdinc := True;
Add_Switch (Argv, Compiler, And_Save => And_Save);
-- Set to True to enable output of generated code in source form. This
-- flag is set by the -gnatG switch.
+ Print_Standard : Boolean := False;
+ -- GNAT
+ -- Set to true to enable printing of package standard in source form.
+ -- This flag is set by the -gnatS switch
+
Propagate_Exceptions : Boolean := False;
-- GNAT
-- Indicates if subprogram descriptor exception tables should be
end if;
if Lib_Dir.Default then
- Error_Msg
- (Project,
- "a project extending a library project must specify " &
- "an attribute Library_Dir",
- Data.Location);
+
+ -- If the extending project is a virtual project, we
+ -- put the error message in the library project that
+ -- is extended, rather than in the extending all project.
+ -- Of course, we cannot put it in the virtual extending
+ -- project, because it has no source.
+
+ if Data.Virtual then
+ Error_Msg_Name_1 := Extended_Data.Name;
+
+ Error_Msg
+ (Project,
+ "library project % cannot be virtually extended",
+ Extended_Data.Location);
+
+ else
+ Error_Msg
+ (Project,
+ "a project extending a library project must " &
+ "specify an attribute Library_Dir",
+ Data.Location);
+ end if;
end if;
Projects.Table (Data.Extends).Library := False;
Data.Library_Dir, Data.Display_Library_Dir);
if Data.Library_Dir = No_Name then
+
-- Get the absolute name of the library directory that
-- does not exist, to report an error.
with Scans; use Scans;
with Sinput; use Sinput;
with Sinput.P; use Sinput.P;
+with Snames;
with Table;
with Types; use Types;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
+with System.HTable; use System.HTable;
+
pragma Elaborate_All (GNAT.OS_Lib);
package body Prj.Part is
-- The path name(s) of directories where project files may reside.
-- May be empty.
+ type Extension_Origin is (None, Extending_Simple, Extending_All);
+ -- Type of parameter From_Extended for procedures Parse_Single_Project and
+ -- Post_Parse_Context_Clause. Extending_All means that we are parsing the
+ -- tree rooted at an extending all project.
+
------------------------------------
-- Local Packages and Subprograms --
------------------------------------
-- limited imported projects when there is a circularity with at least
-- one limited imported project file.
+ package Virtual_Hash is new Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Project_Node_Id,
+ No_Element => Empty_Node,
+ Key => Project_Node_Id,
+ Hash => Prj.Tree.Hash,
+ Equal => "=");
+ -- Hash table to store the node id of the project for which a virtual
+ -- extending project need to be created.
+
+ package Processed_Hash is new Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => Project_Node_Id,
+ Hash => Prj.Tree.Hash,
+ Equal => "=");
+ -- Hash table to store the project process when looking for project that
+ -- need to have a virtual extending project, to avoid processing the same
+ -- project twice.
+
+ procedure Create_Virtual_Extending_Project
+ (For_Project : Project_Node_Id;
+ Main_Project : Project_Node_Id);
+ -- Create a virtual extending project of For_Project. Main_Project is
+ -- the extending all project.
+
+ procedure Look_For_Virtual_Projects_For
+ (Proj : Project_Node_Id;
+ Potentially_Virtual : Boolean);
+ -- Look for projects that need to have a virtual extending project.
+ -- This procedure is recursive. If called with Potentially_Virtual set to
+ -- True, then Proj may need an virtual extending project; otherwise it
+ -- does not (because it is already extended), but other projects that it
+ -- imports may need to be virtually extended.
+
procedure Pre_Parse_Context_Clause (Context_Clause : out With_Id);
-- Parse the context clause of a project.
-- Store the paths and locations of the imported projects in table Withs.
(Context_Clause : With_Id;
Imported_Projects : out Project_Node_Id;
Project_Directory : Name_Id;
- From_Extended : Boolean);
+ From_Extended : Extension_Origin);
-- Parse the imported projects that have been stored in table Withs,
-- if any. From_Extended is used for the call to Parse_Single_Project
-- below.
(Project : out Project_Node_Id;
Path_Name : String;
Extended : Boolean;
- From_Extended : Boolean);
+ From_Extended : Extension_Origin);
-- Parse a project file.
-- Recursive procedure: it calls itself for imported and extended
- -- projects. When From_Extended is True, if the project has already
+ -- projects. When From_Extended is not None, if the project has already
-- been parsed and is an extended project A, return the ultimate
-- (not extended) project that extends A.
-- Returns No_Name if the path name is invalid, because the corresponding
-- project name does not have the syntax of an ada identifier.
+ --------------------------------------
+ -- Create_Virtual_Extending_Project --
+ --------------------------------------
+
+ procedure Create_Virtual_Extending_Project
+ (For_Project : Project_Node_Id;
+ Main_Project : Project_Node_Id)
+ is
+
+ Virtual_Name : constant String :=
+ Virtual_Prefix &
+ Get_Name_String (Name_Of (For_Project));
+ -- The name of the virtual extending project
+
+ Virtual_Name_Id : Name_Id;
+ -- Virtual extending project name id
+
+ Virtual_Path_Id : Name_Id;
+ -- Fake path name of the virtual extending project. The directory is
+ -- the same directory as the extending all project.
+
+ Virtual_Dir_Id : constant Name_Id :=
+ Immediate_Directory_Of (Path_Name_Of (Main_Project));
+ -- The directory of the extending all project
+
+ -- The source of the virtual extending project is something like:
+
+ -- project V$<project name> extends <project path> is
+
+ -- for Source_Dirs use ();
+
+ -- end V$<project name>;
+
+ -- The project directory cannot be specified during parsing; it will be
+ -- put directly in the virtual extending project data during processing.
+
+ -- Nodes that made up the virtual extending project
+
+ Virtual_Project : constant Project_Node_Id :=
+ Default_Project_Node (N_Project);
+ With_Clause : constant Project_Node_Id :=
+ Default_Project_Node (N_With_Clause);
+ Project_Declaration : constant Project_Node_Id :=
+ Default_Project_Node (N_Project_Declaration);
+ Source_Dirs_Declaration : constant Project_Node_Id :=
+ Default_Project_Node (N_Declarative_Item);
+ Source_Dirs_Attribute : constant Project_Node_Id :=
+ Default_Project_Node
+ (N_Attribute_Declaration, List);
+ Source_Dirs_Expression : constant Project_Node_Id :=
+ Default_Project_Node (N_Expression, List);
+ Source_Dirs_Term : constant Project_Node_Id :=
+ Default_Project_Node (N_Term, List);
+ Source_Dirs_List : constant Project_Node_Id :=
+ Default_Project_Node
+ (N_Literal_String_List, List);
+
+ begin
+ -- Get the virtual name id
+
+ Name_Len := Virtual_Name'Length;
+ Name_Buffer (1 .. Name_Len) := Virtual_Name;
+ Virtual_Name_Id := Name_Find;
+
+ -- Get the virtual path name
+
+ Get_Name_String (Path_Name_Of (Main_Project));
+
+ while Name_Len > 0
+ and then Name_Buffer (Name_Len) /= Directory_Separator
+ and then Name_Buffer (Name_Len) /= '/'
+ loop
+ Name_Len := Name_Len - 1;
+ end loop;
+
+ Name_Buffer (Name_Len + 1 .. Name_Len + Virtual_Name'Length) :=
+ Virtual_Name;
+ Name_Len := Name_Len + Virtual_Name'Length;
+ Virtual_Path_Id := Name_Find;
+
+ -- With clause
+
+ Set_Name_Of (With_Clause, Virtual_Name_Id);
+ Set_Path_Name_Of (With_Clause, Virtual_Path_Id);
+ Set_Project_Node_Of (With_Clause, Virtual_Project);
+ Set_Next_With_Clause_Of
+ (With_Clause, First_With_Clause_Of (Main_Project));
+ Set_First_With_Clause_Of (Main_Project, With_Clause);
+
+ -- Virtual project node
+
+ Set_Name_Of (Virtual_Project, Virtual_Name_Id);
+ Set_Path_Name_Of (Virtual_Project, Virtual_Path_Id);
+ Set_Location_Of (Virtual_Project, Location_Of (Main_Project));
+ Set_Directory_Of (Virtual_Project, Virtual_Dir_Id);
+ Set_Project_Declaration_Of (Virtual_Project, Project_Declaration);
+ Set_Extended_Project_Path_Of
+ (Virtual_Project, Path_Name_Of (For_Project));
+
+ -- Project declaration
+
+ Set_First_Declarative_Item_Of
+ (Project_Declaration, Source_Dirs_Declaration);
+ Set_Extended_Project_Of (Project_Declaration, For_Project);
+
+ -- Source_Dirs declaration
+
+ Set_Current_Item_Node (Source_Dirs_Declaration, Source_Dirs_Attribute);
+
+ -- Source_Dirs attribute
+
+ Set_Name_Of (Source_Dirs_Attribute, Snames.Name_Source_Dirs);
+ Set_Expression_Of (Source_Dirs_Attribute, Source_Dirs_Expression);
+
+ -- Source_Dirs expression
+
+ Set_First_Term (Source_Dirs_Expression, Source_Dirs_Term);
+
+ -- Source_Dirs term
+
+ Set_Current_Term (Source_Dirs_Term, Source_Dirs_List);
+
+ -- Source_Dirs empty list: nothing to do
+
+ end Create_Virtual_Extending_Project;
+
----------------------------
-- Immediate_Directory_Of --
----------------------------
return Name_Find;
end Immediate_Directory_Of;
+ -----------------------------------
+ -- Look_For_Virtual_Projects_For --
+ -----------------------------------
+
+ procedure Look_For_Virtual_Projects_For
+ (Proj : Project_Node_Id;
+ Potentially_Virtual : Boolean)
+
+ is
+ Declaration : Project_Node_Id := Empty_Node;
+ -- Node for the project declaration of Proj
+
+ With_Clause : Project_Node_Id := Empty_Node;
+ -- Node for a with clause of Proj
+
+ Imported : Project_Node_Id := Empty_Node;
+ -- Node for a project imported by Proj
+
+ Extended : Project_Node_Id := Empty_Node;
+ -- Node for the eventual project extended by Proj
+
+ begin
+ -- Nothing to do if Proj is not defined or if it has already been
+ -- processed.
+
+ if Proj /= Empty_Node and then not Processed_Hash.Get (Proj) then
+ -- Make sure the project will not be processed again
+
+ Processed_Hash.Set (Proj, True);
+
+ Declaration := Project_Declaration_Of (Proj);
+
+ if Declaration /= Empty_Node then
+ Extended := Extended_Project_Of (Declaration);
+ end if;
+
+ -- If this is a project that may need a virtual extending project
+ -- and it is not itself an extending project, put it in the list.
+
+ if Potentially_Virtual and then Extended = Empty_Node then
+ Virtual_Hash.Set (Proj, Proj);
+ end if;
+
+ -- Now check the projects it imports
+
+ With_Clause := First_With_Clause_Of (Proj);
+
+ while With_Clause /= Empty_Node loop
+ Imported := Project_Node_Of (With_Clause);
+
+ if Imported /= Empty_Node then
+ Look_For_Virtual_Projects_For
+ (Imported, Potentially_Virtual => True);
+ end if;
+
+ With_Clause := Next_With_Clause_Of (With_Clause);
+ end loop;
+
+ -- Check also the eventual project extended by Proj. As this project
+ -- is already extended, call recursively with Potentially_Virtual
+ -- being False.
+
+ Look_For_Virtual_Projects_For
+ (Extended, Potentially_Virtual => False);
+ end if;
+ end Look_For_Virtual_Projects_For;
+
-----------
-- Parse --
-----------
(Project => Project,
Path_Name => Path_Name,
Extended => False,
- From_Extended => False);
+ From_Extended => None);
+
+ -- If Project is an extending-all project, create the eventual
+ -- virtual extending projects and check that there are no illegally
+ -- imported projects.
+
+ if Project /= Empty_Node and then Is_Extending_All (Project) then
+ -- First look for projects that potentially need a virtual
+ -- extending project.
+
+ Virtual_Hash.Reset;
+ Processed_Hash.Reset;
+
+ -- Mark the extending all project as processed, to avoid checking
+ -- the imported projects in case of a "limited with" on this
+ -- extending all project.
+
+ Processed_Hash.Set (Project, True);
+
+ declare
+ Declaration : constant Project_Node_Id :=
+ Project_Declaration_Of (Project);
+ begin
+ Look_For_Virtual_Projects_For
+ (Extended_Project_Of (Declaration),
+ Potentially_Virtual => False);
+ end;
+
+ -- Now, check the projects directly imported by the main project.
+ -- Remove from the potentially virtual any project extended by one
+ -- of these imported projects. For non extending imported
+ -- projects, check that they do not belong to the project tree of
+ -- the project being "extended-all" by the main project.
+
+ declare
+ With_Clause : Project_Node_Id :=
+ First_With_Clause_Of (Project);
+ Imported : Project_Node_Id := Empty_Node;
+ Declaration : Project_Node_Id := Empty_Node;
+
+ begin
+ while With_Clause /= Empty_Node loop
+ Imported := Project_Node_Of (With_Clause);
+
+ if Imported /= Empty_Node then
+ Declaration := Project_Declaration_Of (Imported);
+
+ if Extended_Project_Of (Declaration) /= Empty_Node then
+ loop
+ Imported := Extended_Project_Of (Declaration);
+ exit when Imported = Empty_Node;
+ Virtual_Hash.Remove (Imported);
+ Declaration := Project_Declaration_Of (Imported);
+ end loop;
+
+ elsif Virtual_Hash.Get (Imported) /= Empty_Node then
+ Error_Msg
+ ("this project cannot be imported directly",
+ Location_Of (With_Clause));
+ end if;
+
+ end if;
+
+ With_Clause := Next_With_Clause_Of (With_Clause);
+ end loop;
+ end;
+
+ -- Now create all the virtual extending projects
+
+ declare
+ Proj : Project_Node_Id := Virtual_Hash.Get_First;
+ begin
+ while Proj /= Empty_Node loop
+ Create_Virtual_Extending_Project (Proj, Project);
+ Proj := Virtual_Hash.Get_Next;
+ end loop;
+ end;
+ end if;
-- If there were any kind of error during the parsing, serious
-- or not, then the parsing fails.
(Context_Clause : With_Id;
Imported_Projects : out Project_Node_Id;
Project_Directory : Name_Id;
- From_Extended : Boolean)
+ From_Extended : Extension_Origin)
is
Current_With_Clause : With_Id := Context_Clause;
(Project : out Project_Node_Id;
Path_Name : String;
Extended : Boolean;
- From_Extended : Boolean)
+ From_Extended : Extension_Origin)
is
Normed_Path_Name : Name_Id;
Canonical_Path_Name : Name_Id;
-- in an extended project, replace A with the ultimate project
-- extending A.
- if From_Extended then
+ if From_Extended /= None then
declare
Decl : Project_Node_Id :=
Project_Declaration_Of
declare
Imported_Projects : Project_Node_Id := Empty_Node;
+ From_Ext : Extension_Origin := None;
begin
+ -- Extending_All is always propagated
+
+ if From_Extended = Extending_All then
+ From_Ext := Extending_All;
+
+ -- Otherwise, From_Extended is set to Extending_Single if the
+ -- current project is an extending project.
+
+ elsif Extended then
+ From_Ext := Extending_Simple;
+ end if;
+
Post_Parse_Context_Clause
(Context_Clause => First_With,
Imported_Projects => Imported_Projects,
Project_Directory => Project_Directory,
- From_Extended => Extended);
+ From_Extended => From_Ext);
Set_First_With_Clause_Of (Project, Imported_Projects);
end;
-- We are extending another project
Scan; -- scan past EXTENDS
+
+ if Token = Tok_All then
+ Set_Is_Extending_All (Project);
+ Scan; -- scan past ALL
+ end if;
+
Expect (Tok_String_Literal, "literal string");
if Token = Tok_String_Literal then
end if;
else
- Parse_Single_Project
- (Project => Extended_Project,
- Path_Name => Extended_Project_Path_Name,
- Extended => True,
- From_Extended => False);
+ declare
+ From_Extended : Extension_Origin := None;
+
+ begin
+ if Is_Extending_All (Project) then
+ From_Extended := Extending_All;
+ end if;
+
+ Parse_Single_Project
+ (Project => Extended_Project,
+ Path_Name => Extended_Project_Path_Name,
+ Extended => True,
+ From_Extended => From_Extended);
+ end;
+
+ -- A project that extends an extending-all project is also
+ -- an extending-all project.
+
+ if Is_Extending_All (Extended_Project) then
+ Set_Is_Extending_All (Project);
+ end if;
end if;
end;
end if;
end if;
+ -- Check that a non extending-all project does not import an
+ -- extending-all project.
+
+ if not Is_Extending_All (Project) then
+ declare
+ With_Clause : Project_Node_Id := First_With_Clause_Of (Project);
+ Imported : Project_Node_Id := Empty_Node;
+
+ begin
+ With_Clause_Loop :
+ while With_Clause /= Empty_Node loop
+ Imported := Project_Node_Of (With_Clause);
+ With_Clause := Next_With_Clause_Of (With_Clause);
+
+ if Is_Extending_All (Imported) then
+ Error_Msg_Name_1 := Name_Of (Imported);
+ Error_Msg ("cannot import extending-all project {",
+ Token_Ptr);
+ exit With_Clause_Loop;
+ end if;
+ end loop With_Clause_Loop;
+ end;
+ end if;
+
-- Check that a project with a name including a dot either imports
-- or extends the project whose name precedes the last dot.
Check (Project);
end if;
+ -- If main project is an extending all project, set the object
+ -- directory of all virtual extending projects to the object directory
+ -- of the main project.
+
+ if Project /= No_Project
+ and then Is_Extending_All (From_Project_Node)
+ then
+ declare
+ Object_Dir : constant Name_Id :=
+ Projects.Table (Project).Object_Directory;
+ begin
+ for Index in Projects.First .. Projects.Last loop
+ if Projects.Table (Index).Virtual then
+ Projects.Table (Index).Object_Directory := Object_Dir;
+ end if;
+ end loop;
+ end;
+ end if;
+
-- Check that no extended project shares its object directory with
-- another project.
and then Projects.Table (Prj).Sources_Present
and then Projects.Table (Prj).Object_Directory = Obj_Dir
then
- Error_Msg_Name_1 := Projects.Table (Extending).Name;
- Error_Msg_Name_2 := Projects.Table (Extended).Name;
+ if Projects.Table (Extending).Virtual then
+ Error_Msg_Name_1 := Projects.Table (Extended).Name;
- if Error_Report = null then
- Error_Msg ("project % cannot extend project %",
- Projects.Table (Extending).Location);
+ if Error_Report = null then
+ Error_Msg
+ ("project % cannot be extended by " &
+ "a virtual project",
+ Projects.Table (Extending).Location);
+
+ else
+ Error_Report
+ ("project """ &
+ Get_Name_String (Error_Msg_Name_1) &
+ """ cannot be extended by a virtual project",
+ Project);
+ end if;
else
- Error_Report
- ("project """ &
- Get_Name_String (Error_Msg_Name_1) &
- """ cannot extend project """ &
- Get_Name_String (Error_Msg_Name_2) & '"',
- Project);
+ Error_Msg_Name_1 := Projects.Table (Extending).Name;
+ Error_Msg_Name_2 := Projects.Table (Extended).Name;
+
+ if Error_Report = null then
+ Error_Msg ("project % cannot extend project %",
+ Projects.Table (Extending).Location);
+
+ else
+ Error_Report
+ ("project """ &
+ Get_Name_String (Error_Msg_Name_1) &
+ """ cannot extend project """ &
+ Get_Name_String (Error_Msg_Name_2) & '"',
+ Project);
+ end if;
end if;
Error_Msg_Name_1 := Projects.Table (Extended).Name;
Processed_Data.Name := Name;
+ Get_Name_String (Name);
+
+ -- If name starts with the virtual prefix, flag the project as
+ -- being a virtual extending project.
+
+ if Name_Len > Virtual_Prefix'Length
+ and then Name_Buffer (1 .. Virtual_Prefix'Length) =
+ Virtual_Prefix
+ then
+ Processed_Data.Virtual := True;
+ end if;
+
Processed_Data.Display_Path_Name :=
Path_Name_Of (From_Project_Node);
Get_Name_String (Processed_Data.Display_Path_Name);
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
- Case_Insensitive => False);
+ Case_Insensitive => False,
+ Extending_All => False);
return Project_Nodes.Last;
end Default_Project_Node;
return Project_Nodes.Table (Node).Field1;
end First_With_Clause_Of;
+ ----------------------
+ -- Is_Extending_All --
+ ----------------------
+
+ function Is_Extending_All (Node : Project_Node_Id) return Boolean is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Project);
+ return Project_Nodes.Table (Node).Extending_All;
+ end Is_Extending_All;
+
----------
-- Hash --
----------
Project_Nodes.Table (Node).Field1 := To;
end Set_First_With_Clause_Of;
+ --------------------------
+ -- Set_Is_Extending_All --
+ --------------------------
+
+ procedure Set_Is_Extending_All (Node : Project_Node_Id) is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Project);
+ Project_Nodes.Table (Node).Extending_All := True;
+ end Set_Is_Extending_All;
+
-----------------
-- Set_Kind_Of --
-----------------
-- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression,
-- N_Term, N_Variable_Reference or N_Attribute_Reference nodes.
+ function Is_Extending_All (Node : Project_Node_Id) return Boolean;
+ pragma Inline (Is_Extending_All);
+ -- Only valid for N_Project
+
function First_Variable_Of
(Node : Project_Node_Id)
return Variable_Node_Id;
(Node : Project_Node_Id)
return Project_Node_Id;
pragma Inline (Extended_Project_Of);
- -- Only valid for N_With_Clause nodes
+ -- Only valid for N_Project_Declaration nodes
function Current_Item_Node
(Node : Project_Node_Id)
To : Variable_Kind);
pragma Inline (Set_Expression_Kind_Of);
+ procedure Set_Is_Extending_All (Node : Project_Node_Id);
+ pragma Inline (Set_Is_Extending_All);
+
procedure Set_First_Variable_Of
(Node : Project_Node_Id;
To : Variable_Node_Id);
-- N_Atribute_Reference. It indicates for an associative array
-- attribute, that the index is case insensitive.
+ Extending_All : Boolean := False;
+ -- This flag is significant only for N_Project. It indicates that
+ -- the project "extends all" another project.
+
end record;
-- type Project_Node_Kind is
(First_Referred_By => No_Project,
Name => No_Name,
Path_Name => No_Name,
+ Virtual => False,
Display_Path_Name => No_Name,
Location => No_Location,
Mains => Nil_String,
-- Default value of parameter Packages of procedures Parse, in Prj.Pars and
-- Prj.Part, indicating that all packages should be checked.
+ Virtual_Prefix : constant String := "v$";
+ -- The prefix for virtual extending projects. Because of the '$', which is
+ -- normally forbidden for project names, there cannot be any name clash.
+
Project_File_Extension : String := ".gpr";
-- The standard project file name extension.
-- It is not a constant, because Canonical_Case_File_Name is called
-- The path name of the project file.
-- Set by Prj.Proc.Process.
+ Virtual : Boolean := False;
+ -- True for virtual extending projects
+
Display_Path_Name : Name_Id := No_Name;
Location : Source_Ptr := No_Location;
-- Normal case of non-null name given
else
+ if Name'Length > Namelen then
+ raise Name_Error;
+ end if;
+
Namestr (1 .. Name'Length) := Name;
Namestr (Name'Length + 1) := ASCII.NUL;
end if;
-- This is the VxWorks/Cert version of this package
+with System.Init;
+with System.Secondary_Stack;
+
with Unchecked_Conversion;
package body System.Threads is
+ package SSS renames System.Secondary_Stack;
+
Current_ATSD : aliased System.Address := System.Null_Address;
pragma Export (C, Current_ATSD, "__gnat_current_atsd");
function From_Address is
new Unchecked_Conversion (Address, ATSD_Access);
-
-
-----------------------
-- Get_Current_Excep --
-----------------------
Sec_Stack_Size : Natural;
Process_ATSD_Address : System.Address)
is
- pragma Unreferenced (Sec_Stack_Address);
- pragma Unreferenced (Sec_Stack_Size);
- pragma Unreferenced (Process_ATSD_Address);
+ -- Current_ATSD must already be a taskVar of taskIdSelf.
+ -- No assertion because taskVarGet is not available on VxWorks/CERT
+
+ TSD : ATSD_Access := From_Address (Process_ATSD_Address);
+
begin
- null;
+ TSD.Sec_Stack_Addr := Sec_Stack_Address;
+ SSS.SS_Init (TSD.Sec_Stack_Addr, Sec_Stack_Size);
+ Current_ATSD := Process_ATSD_Address;
+
+ System.Init.Install_Handler;
+ System.Init.Init_Float;
end Thread_Body_Enter;
----------------------------------
is
pragma Unreferenced (EO);
begin
+ -- No action for this target
null;
end Thread_Body_Exceptional_Exit;
procedure Thread_Body_Leave is
begin
+ -- No action for this target
null;
end Thread_Body_Leave;
-- This package provides facilities to register a thread to the runtime,
-- and allocate its task specific datas.
+-- pragma Thread_Body is currently supported for:
+-- VxWorks AE653 with the restricted / cert runtime
+
with Ada.Exceptions;
package System.Threads is
Generate_Reference (Par_Name, Pref);
Pref := Prefix (Pref);
- Par_Name := Scope (Par_Name);
+
+ -- If E_Name is the dummy entity for a nonexistent unit,
+ -- its scope is set to Standard_Standard, and no attempt
+ -- should be made to further unwind scopes.
+
+ if Par_Name /= Standard_Standard then
+ Par_Name := Scope (Par_Name);
+ end if;
end loop;
if Present (Entity (Pref))
-- those nodes that contain global information. At instantiation, the
-- information from the associated node is placed on the new copy, so
-- that name resolution is not repeated.
-
+ --
-- Three kinds of source nodes have associated nodes:
-
+ --
-- a) those that can reference (denote) entities, that is identifiers,
-- character literals, expanded_names, operator symbols, operators,
-- and attribute reference nodes. These nodes have an Entity field
-- and are the set of nodes that are in N_Has_Entity.
-
+ --
-- b) aggregates (N_Aggregate and N_Extension_Aggregate)
-
+ --
-- c) selected components (N_Selected_Component)
-
+ --
-- For the first class, the associated node preserves the entity if it is
- -- global. If the generic contains nested instantiations, the associated_
+ -- global. If the generic contains nested instantiations, the associated
-- node itself has been recopied, and a chain of them must be followed.
-
+ --
-- For aggregates, the associated node allows retrieval of the type, which
-- may otherwise not appear in the generic. The view of this type may be
-- different between generic and instantiation, and the full view can be
-- type extensions, the same view exchange may have to be performed for
-- some of the ancestor types, if their view is private at the point of
-- instantiation.
-
+ --
-- Nodes that are selected components in the parse tree may be rewritten
-- as expanded names after resolution, and must be treated as potential
-- entity holders. which is why they also have an Associated_Node.
-
+ --
-- Nodes that do not come from source, such as freeze nodes, do not appear
-- in the generic tree, and need not have an associated node.
-
+ --
-- The associated node is stored in the Associated_Node field. Note that
-- this field overlaps Entity, which is fine, because the whole point is
-- that we don't need or want the normal Entity field in this situation.
CC, Rectype);
end if;
- -- Test for large object that is not on a storage unit
- -- boundary, defined as a large packed array not
- -- represented by a modular type, or an object for
- -- which a size of greater than 64 bits is specified.
-
- if Fbit mod SSU /= 0 then
- if (Is_Packed_Array_Type (Etype (Comp))
- and then Is_Array_Type
- (Packed_Array_Type (Etype (Comp))))
- or else Esize (Etype (Comp)) > Max_Unaligned_Field
- then
- if SSU = 8 then
- Error_Msg_N
- ("large component must be on byte boundary",
- First_Bit (CC));
- else
- Error_Msg_N
- ("large component must be on word boundary",
- First_Bit (CC));
- end if;
- end if;
- end if;
-
-- This information is also set in the
-- corresponding component of the base type,
-- found by accessing the Original_Record_Component
--------------------------
procedure Check_Expr_Constants (Nod : Node_Id) is
+ Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent);
+ Ent : Entity_Id := Empty;
+
begin
if Nkind (Nod) in N_Has_Etype
and then Etype (Nod) = Any_Type
return;
when N_Identifier | N_Expanded_Name =>
+ Ent := Entity (Nod);
-- We need to look at the original node if it is different
-- from the node, since we may have rewritten things and
-- is not constant, even if the constituents might be
-- acceptable, as in A'Address + offset.
- if Ekind (Entity (Nod)) = E_Variable
- and then Nkind (Declaration_Node (Entity (Nod)))
+ if Ekind (Ent) = E_Variable
+ and then Nkind (Declaration_Node (Ent))
= N_Object_Declaration
and then
- No (Expression (Declaration_Node (Entity (Nod))))
+ No (Expression (Declaration_Node (Ent)))
+ then
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+
+ -- If entity is constant, it may be the result of expanding
+ -- a check. We must verify that its declaration appears
+ -- before the object in question, else we also reject the
+ -- address clause.
+
+ elsif Ekind (Ent) = E_Constant
+ and then In_Same_Source_Unit (Ent, U_Ent)
+ and then Sloc (Ent) > Loc_U_Ent
then
Error_Msg_NE
("invalid address clause for initialized object &!",
Nod, U_Ent);
end if;
+
return;
end if;
-- Otherwise look at the identifier and see if it is OK.
- declare
- Ent : constant Entity_Id := Entity (Nod);
- Loc_Ent : constant Source_Ptr := Sloc (Ent);
- Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent);
-
- begin
- if Ekind (Ent) = E_Named_Integer
- or else
- Ekind (Ent) = E_Named_Real
- or else
- Is_Type (Ent)
- then
- return;
-
- elsif
- Ekind (Ent) = E_Constant
- or else
- Ekind (Ent) = E_In_Parameter
- then
- -- This is the case where we must have Ent defined
- -- before U_Ent. Clearly if they are in different
- -- units this requirement is met since the unit
- -- containing Ent is already processed.
-
- if not In_Same_Source_Unit (Ent, U_Ent) then
- return;
+ if Ekind (Ent) = E_Named_Integer
+ or else
+ Ekind (Ent) = E_Named_Real
+ or else
+ Is_Type (Ent)
+ then
+ return;
- -- Otherwise location of Ent must be before the
- -- location of U_Ent, that's what prior defined means.
+ elsif
+ Ekind (Ent) = E_Constant
+ or else
+ Ekind (Ent) = E_In_Parameter
+ then
+ -- This is the case where we must have Ent defined
+ -- before U_Ent. Clearly if they are in different
+ -- units this requirement is met since the unit
+ -- containing Ent is already processed.
- elsif Loc_Ent < Loc_U_Ent then
- return;
+ if not In_Same_Source_Unit (Ent, U_Ent) then
+ return;
- else
- Error_Msg_NE
- ("invalid address clause for initialized object &!",
- Nod, U_Ent);
- Error_Msg_Name_1 := Chars (Ent);
- Error_Msg_Name_2 := Chars (U_Ent);
- Error_Msg_N
- ("\% must be defined before % ('R'M 13.1(22))!",
- Nod);
- end if;
+ -- Otherwise location of Ent must be before the
+ -- location of U_Ent, that's what prior defined means.
- elsif Nkind (Original_Node (Nod)) = N_Function_Call then
- Check_Expr_Constants (Original_Node (Nod));
+ elsif Sloc (Ent) < Loc_U_Ent then
+ return;
else
Error_Msg_NE
("invalid address clause for initialized object &!",
Nod, U_Ent);
+ Error_Msg_Name_1 := Chars (Ent);
+ Error_Msg_Name_2 := Chars (U_Ent);
+ Error_Msg_N
+ ("\% must be defined before % ('R'M 13.1(22))!",
+ Nod);
+ end if;
- if Comes_From_Source (Ent) then
- Error_Msg_Name_1 := Chars (Ent);
- Error_Msg_N
- ("\reference to variable% not allowed"
- & " ('R'M 13.1(22))!", Nod);
- else
- Error_Msg_N
- ("non-static expression not allowed"
- & " ('R'M 13.1(22))!", Nod);
- end if;
+ elsif Nkind (Original_Node (Nod)) = N_Function_Call then
+ Check_Expr_Constants (Original_Node (Nod));
+
+ else
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+
+ if Comes_From_Source (Ent) then
+ Error_Msg_Name_1 := Chars (Ent);
+ Error_Msg_N
+ ("\reference to variable% not allowed"
+ & " ('R'M 13.1(22))!", Nod);
+ else
+ Error_Msg_N
+ ("non-static expression not allowed"
+ & " ('R'M 13.1(22))!", Nod);
end if;
- end;
+ end if;
when N_Integer_Literal |
N_Real_Literal |
with Freeze; use Freeze;
with Lib.Xref; use Lib.Xref;
with Nlists; use Nlists;
+with Nmake; use Nmake;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Case; use Sem_Case;
-- Analyze_Iteration_Scheme --
------------------------------
+
procedure Analyze_Iteration_Scheme (N : Node_Id) is
+ procedure Check_Controlled_Array_Attribute (DS : Node_Id);
+ -- If the bounds are given by a 'Range reference on a function call
+ -- that returns a controlled array, introduce an explicit declaration
+ -- to capture the bounds, so that the function result can be finalized
+ -- in timely fashion.
+
+ --------------------------------------
+ -- Check_Controlled_Array_Attribute --
+ --------------------------------------
+
+ procedure Check_Controlled_Array_Attribute (DS : Node_Id) is
+ begin
+ if Nkind (DS) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (DS))
+ and then Ekind (Entity (Prefix (DS))) = E_Function
+ and then Is_Array_Type (Etype (Entity (Prefix (DS))))
+ and then
+ Is_Controlled (
+ Component_Type (Etype (Entity (Prefix (DS)))))
+ and then Expander_Active
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Arr : constant Entity_Id :=
+ Etype (Entity (Prefix (DS)));
+ Indx : constant Entity_Id :=
+ Base_Type (Etype (First_Index (Arr)));
+ Subt : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('S'));
+ Decl : Node_Id;
+
+ begin
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Subt,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (Indx, Loc),
+ Constraint =>
+ Make_Range_Constraint (Loc,
+ Relocate_Node (DS))));
+ Insert_Before (Parent (N), Decl);
+ Analyze (Decl);
+
+ Rewrite (DS,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Subt, Loc),
+ Attribute_Name => Attribute_Name (DS)));
+ Analyze (DS);
+ end;
+ end if;
+ end Check_Controlled_Array_Attribute;
+
+ -- Start of processing for Analyze_Iteration_Scheme
+
begin
-- For an infinite loop, there is no iteration scheme
Set_Etype (DS, Any_Type);
end if;
+ Check_Controlled_Array_Attribute (DS);
Make_Index (DS, LP);
Set_Ekind (Id, E_Loop_Parameter);
Error_Msg_N (
"invalid prefix in selected component&", P);
+ if Is_Access_Type (P_Type)
+ and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type
+ then
+ Error_Msg_Node_2 := Selector_Name (N);
+ Error_Msg_NE (
+ "\incomplete type& has no visible component&", P,
+ Designated_Type (P_Type));
+ end if;
+
else
Error_Msg_N (
"invalid prefix in selected component", P);
return Node4 (N);
end Entity;
+ function Entity_Or_Associated_Node
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind in N_Has_Entity
+ or else NT (N).Nkind = N_Freeze_Entity);
+ return Node4 (N);
+ end Entity_Or_Associated_Node;
+
function Entry_Body_Formal_Part
(N : Node_Id) return Node_Id is
begin
-- abbreviations are used:
-- Note: the utility program that creates the Treeprs spec (in the file
- -- treeprs.ads) knows about the special fields here, so it must be
+ -- xtreeprs.adb) knows about the special fields here, so it must be
-- modified if any change is made to these fields.
-- "plus fields for binary operator"
-- Associated_Node (Node4-Sem)
-- Present in nodes that can denote an entity: identifiers, character
- -- literals, operator symbols, expanded names, operator nodes and
+ -- literals, operator symbols, expanded names, operator nodes, and
-- attribute reference nodes (all these nodes have an Entity field).
-- This field is also present in N_Aggregate, N_Selected_Component,
- -- and N_Extension_Aggregate nodes. This field is used during generic
- -- processing to relate nodes in the original template to nodes in the
- -- generic copy. It overlaps the Entity field, and is used to capture
- -- global references in the analyzed copy and place them in the instance.
- -- See description in Sem_Ch12 for further details on this usage.
+ -- and N_Extension_Aggregate nodes. This field is used in generic
+ -- processing to create links between the generic template and the
+ -- generic copy. See Sem_Ch12.Get_Associated_Node for full details.
+ -- Note that this field overlaps Entity, which is fine, since, as
+ -- explained in Sem_Ch12, the normal function of Entity is not
+ -- required at the point where the Associated_Node is set. Note
+ -- also, that in generic templates, this means that the Entity field
+ -- does not necessarily point to an Entity. Since the back end is
+ -- expected to ignore generic templates, this is harmless.
-- At_End_Proc (Node1)
-- This field is present in an N_Handled_Sequence_Of_Statements node.
-- incorrect (e.g. during overload resolution, Entity is initially
-- set to the first possible correct interpretation, and then later
-- modified if necessary to contain the correct value after resolution).
- -- Note that Associated_Node overlays this field during the processing
- -- of generics. See Sem_Ch12 for further details.
+ -- Note that this field overlaps Associated_Node, which is used during
+ -- generic processing (see Sem_Ch12 for details). Note also that in
+ -- generic templates, this means that the Entity field does not always
+ -- point to an Entity. Since the back end is expected to ignore
+ -- generic templates, this is harmless.
+
+ -- Entity_Or_Associated_Node (Node4-Sem)
+ -- A synonym for both Entity and Asasociated_Node. Used by convention
+ -- in the code when referencing this field in cases where it is not
+ -- known whether the field contains an Entity or an Associated_Node.
-- Etype (Node5-Sem)
-- Appears in all expression nodes, all direct names, and all
function Entity
(N : Node_Id) return Node_Id; -- Node4
+ function Entity_Or_Associated_Node
+ (N : Node_Id) return Node_Id; -- Node4
+
function Entry_Body_Formal_Part
(N : Node_Id) return Node_Id; -- Node5
pragma Inline (End_Label);
pragma Inline (End_Span);
pragma Inline (Entity);
+ pragma Inline (Entity_Or_Associated_Node);
pragma Inline (Entry_Body_Formal_Part);
pragma Inline (Entry_Call_Alternative);
pragma Inline (Entry_Call_Statement);
Dump_Generated_Only : Boolean;
-- Set True if the -gnatG (dump generated tree) debug flag is set
- -- or for Print_Generated_Code (-gnatG) or Dump_Gnerated_Code (-gnatD).
+ -- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD).
Dump_Freeze_Null : Boolean;
-- Set True if freeze nodes and non-source null statements output
then
Write_Id (Entity (Parent (N)));
- -- For any other kind of node with an associated entity, output it.
+ -- For any other node with an associated entity, output it
elsif Nkind (N) in N_Has_Entity
- and then Present (Entity (N))
+ and then Present (Entity_Or_Associated_Node (N))
+ and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity
then
Write_Id (Entity (N));
when False =>
- -- There are only two front-end switches that
- -- do not start with -gnat, namely -I and --RTS
+ -- There are few front-end switches that
+ -- do not start with -gnat: -I, --RTS, -nostdlib
if Switch_Chars (Ptr) = 'I' then
Store_Switch := False;
Ptr := Max + 1;
+ -- Processing of -nostdlib
+
+ elsif Ptr + 7 = Max
+ and then Switch_Chars (Ptr .. Ptr + 7) = "nostdlib"
+ then
+ Opt.No_Stdlib := True;
+ Ptr := Max + 1;
+
-- Processing of the --RTS switch. --RTS has been modified by
-- gcc and is now of the form -fRTS
Ptr := Ptr + 1;
Operating_Mode := Check_Syntax;
+ -- Processing for S switch
+
+ when 'S' =>
+ Print_Standard := True;
+ Ptr := Ptr + 1;
+
-- Processing for t switch
when 't' =>
Write_Switch_Char ("s");
Write_Line ("Syntax check only");
+ -- Lines for -gnatS switch
+
+ Write_Switch_Char ("S");
+ Write_Line ("Print listing of package Standard");
+
-- Lines for -gnatt switch
Write_Switch_Char ("t");
--
-- Do not look in the default directory for source files of the runtime.
+ S_GCC_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
+ "-nostdlib";
+ -- /NOSTD_LIBRARIES
+ --
+ -- Do not look for library files in the system default directory.
+
S_GCC_Opt : aliased constant S := "/OPTIMIZE=" &
"ALL " &
"-O2,!-O0,!-O1,!-O3 " &
S_GCC_Noadc 'Access,
S_GCC_Noload 'Access,
S_GCC_Nostinc 'Access,
+ S_GCC_Nostlib 'Access,
S_GCC_Opt 'Access,
S_GCC_OptX 'Access,
S_GCC_Polling 'Access,
git://gcc.gnu.org / gcc.git / commitdiff