diff options
41 files changed, 1185 insertions, 265 deletions
diff --git a/gcc/ada/5ytiitho.adb b/gcc/ada/5ytiitho.adb index f0027fd24e1..ad2924d559d 100644 --- a/gcc/ada/5ytiitho.adb +++ b/gcc/ada/5ytiitho.adb @@ -35,10 +35,9 @@ -- 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; @@ -51,16 +50,7 @@ procedure Initialize_Task_Hooks is 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; diff --git a/gcc/ada/5zinit.adb b/gcc/ada/5zinit.adb index c947057f044..e384d3b5116 100644 --- a/gcc/ada/5zinit.adb +++ b/gcc/ada/5zinit.adb @@ -104,11 +104,6 @@ package body System.Init is -- 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 -- ------------------------ @@ -238,16 +233,6 @@ package body System.Init is 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 -- --------------------- diff --git a/gcc/ada/5zthrini.adb b/gcc/ada/5zthrini.adb index ded9a5118bb..22777f49e7c 100644 --- a/gcc/ada/5zthrini.adb +++ b/gcc/ada/5zthrini.adb @@ -35,6 +35,7 @@ -- 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; @@ -64,12 +65,16 @@ package body System.Threads.Initialization is -------------- 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 @@ -78,36 +83,34 @@ package body System.Threads.Initialization is 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; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 674df74dad4..52e00960b0e 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -1339,7 +1339,10 @@ __gnat_stat (char *name, struct stat *statbuf) 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); diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 8db6a302ef0..82b9135c2ec 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -1894,9 +1894,7 @@ package body Bindgen is --------------------- 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 @@ -1929,7 +1927,7 @@ package body Bindgen is -- 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; @@ -1944,7 +1942,7 @@ package body Bindgen is -- 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; diff --git a/gcc/ada/bld.adb b/gcc/ada/bld.adb index 07add38e2e0..725e9ca3740 100644 --- a/gcc/ada/bld.adb +++ b/gcc/ada/bld.adb @@ -2595,6 +2595,25 @@ package body Bld is -- 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 ("),)"); diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index ecc0f855294..81b8db54e3d 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -80,12 +80,6 @@ package body Comperr is -- 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 @@ -99,6 +93,9 @@ package body Comperr is 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 @@ -264,7 +261,13 @@ package body Comperr is -- 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."); @@ -274,15 +277,9 @@ package body Comperr is ("| 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)."); @@ -307,7 +304,7 @@ package body Comperr is ("| (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; @@ -317,7 +314,7 @@ package body Comperr is "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)."); diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 93b84a86f27..9cad4bea44d 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -33,6 +33,7 @@ with Namet; use Namet; 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; @@ -120,6 +121,9 @@ package body CStand is 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; @@ -1243,6 +1247,12 @@ package body CStand is -- 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; ------------------------------------ @@ -1417,6 +1427,249 @@ package body CStand is 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 -- ---------------------- diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 09ec0dccd49..3c6a67f5ac0 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -338,7 +338,9 @@ package body Debug is -- 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 diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 24be5432e2d..9a6a2d8edc5 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -930,7 +930,7 @@ package Einfo is -- 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. -- @@ -2830,7 +2830,7 @@ package Einfo is -- 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. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 9b5d3bfffe9..5ac60af114f 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2944,6 +2944,8 @@ package body Exp_Ch6 is 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 @@ -3046,6 +3048,7 @@ package body Exp_Ch6 is Exception_Handlers => Excep_Handlers)); Analyze (Handled_Statement_Sequence (N)); + End_Scope; end Expand_Thread_Body; -- Start of processing for Expand_N_Subprogram_Body diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index dcae02ee0b7..6f9b8a0f2c6 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -54,6 +54,7 @@ with Sem; with Sem_Ch8; with Sem_Ch12; with Sem_Ch13; +with Sem_Elim; with Sem_Eval; with Sem_Type; with Sinfo; use Sinfo; @@ -118,6 +119,7 @@ begin Sem_Ch8.Initialize; Sem_Ch12.Initialize; Sem_Ch13.Initialize; + Sem_Elim.Initialize; Sem_Eval.Initialize; Sem_Type.Init_Interp_Tables; diff --git a/gcc/ada/gnatvsn.adb b/gcc/ada/gnatvsn.adb index cbeadd5d3f6..b15c6faf582 100644 --- a/gcc/ada/gnatvsn.adb +++ b/gcc/ada/gnatvsn.adb @@ -41,6 +41,15 @@ package body Gnatvsn is 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 -- ------------------------- diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index f665e5339ee..9cbb871a7a2 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -45,12 +45,24 @@ package Gnatvsn is -- 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 diff --git a/gcc/ada/gprcmd.adb b/gcc/ada/gprcmd.adb index 3d5766df703..5cefb3b8684 100644 --- a/gcc/ada/gprcmd.adb +++ b/gcc/ada/gprcmd.adb @@ -37,6 +37,7 @@ -- 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; @@ -45,6 +46,8 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; 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 @@ -418,6 +421,40 @@ begin 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; diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 285e2512027..2f669751b00 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -78,7 +78,6 @@ package body Lib.Load is 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; @@ -98,11 +97,12 @@ package body Lib.Load is 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)))); @@ -113,19 +113,14 @@ package body Lib.Load is 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, diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index db01b6b362f..21d299ebb85 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -460,8 +460,7 @@ package body Lib is 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 @@ -534,8 +533,7 @@ package body Lib is ---------------------------------- 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 @@ -613,8 +611,7 @@ package body Lib is -------------------------------- 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 @@ -647,10 +644,7 @@ package body Lib is 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; @@ -676,8 +670,7 @@ package body Lib is ---------------------------------- 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)); @@ -718,8 +711,7 @@ package body Lib is 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)); diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index e01ab65ff6b..836491b0145 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -462,8 +462,7 @@ package Lib is -- 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 @@ -472,15 +471,12 @@ package Lib is -- 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 @@ -490,9 +486,7 @@ package Lib is -- 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. @@ -515,8 +509,7 @@ package Lib is -- 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. @@ -603,8 +596,7 @@ package Lib is -- 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 diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 113b8d1633b..d734dd54f10 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -3595,7 +3595,7 @@ package body Make is 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 @@ -6848,11 +6848,13 @@ package body Make is -- 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); diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 356ed026927..356564a12ab 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -719,6 +719,11 @@ package Opt is -- 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 diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 27662a3f89e..5a47f8770fb 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -2973,11 +2973,28 @@ package body Prj.Nmsc is 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; @@ -3001,6 +3018,7 @@ package body Prj.Nmsc is 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. diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 28e4af9bd44..73d7c574575 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -35,6 +35,7 @@ with Prj.Err; use Prj.Err; with Scans; use Scans; with Sinput; use Sinput; with Sinput.P; use Sinput.P; +with Snames; with Table; with Types; use Types; @@ -44,6 +45,8 @@ with Ada.Exceptions; use Ada.Exceptions; 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 @@ -62,6 +65,11 @@ 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 -- ------------------------------------ @@ -105,6 +113,42 @@ package body Prj.Part is -- 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. @@ -115,7 +159,7 @@ package body Prj.Part is (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. @@ -124,10 +168,10 @@ package body Prj.Part is (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. @@ -148,6 +192,132 @@ package body Prj.Part is -- 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 -- ---------------------------- @@ -181,6 +351,73 @@ package body Prj.Part is 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 -- ----------- @@ -228,7 +465,84 @@ package body Prj.Part is (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. @@ -338,7 +652,7 @@ package body Prj.Part is (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; @@ -494,7 +808,7 @@ package body Prj.Part is (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; @@ -583,7 +897,7 @@ package body Prj.Part is -- 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 @@ -745,13 +1059,26 @@ package body Prj.Part is 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; @@ -797,6 +1124,12 @@ package body Prj.Part is -- 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 @@ -836,11 +1169,27 @@ package body Prj.Part is 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; @@ -848,6 +1197,30 @@ package body Prj.Part is 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. diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index fc0d816d9af..21585af36cd 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -840,6 +840,25 @@ package body Prj.Proc is 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. @@ -855,20 +874,39 @@ package body Prj.Proc is 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; @@ -1789,6 +1827,18 @@ package body Prj.Proc is 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); diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index 6587d35300b..74cd73d7b13 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -166,7 +166,8 @@ package body Prj.Tree is 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; @@ -485,6 +486,19 @@ package body Prj.Tree is 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 -- ---------- @@ -1237,6 +1251,19 @@ package body Prj.Tree is 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 -- ----------------- diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index 4ddebb35763..15156e869d3 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -135,6 +135,10 @@ package Prj.Tree is -- 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; @@ -220,7 +224,7 @@ package Prj.Tree is (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) @@ -425,6 +429,9 @@ package Prj.Tree is 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); @@ -685,6 +692,10 @@ package Prj.Tree is -- 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 diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index f03f5559622..04fc0e6c848 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -77,6 +77,7 @@ package body Prj 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, diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index b9dff5988b8..bfb67d6d395 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -47,6 +47,10 @@ package Prj is -- 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 @@ -339,6 +343,9 @@ package Prj is -- 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; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index 9028fd694ba..b60cce5215c 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -812,6 +812,10 @@ package body System.File_IO is -- 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; diff --git a/gcc/ada/s-thread.adb b/gcc/ada/s-thread.adb index 97f9e88cff4..850a423b8f5 100644 --- a/gcc/ada/s-thread.adb +++ b/gcc/ada/s-thread.adb @@ -33,18 +33,21 @@ -- 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 -- ----------------------- @@ -109,11 +112,18 @@ package body System.Threads is 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; ---------------------------------- @@ -125,6 +135,7 @@ package body System.Threads is is pragma Unreferenced (EO); begin + -- No action for this target null; end Thread_Body_Exceptional_Exit; @@ -134,6 +145,7 @@ package body System.Threads is procedure Thread_Body_Leave is begin + -- No action for this target null; end Thread_Body_Leave; diff --git a/gcc/ada/s-thread.ads b/gcc/ada/s-thread.ads index a316afc592b..6badd1668b4 100644 --- a/gcc/ada/s-thread.ads +++ b/gcc/ada/s-thread.ads @@ -34,6 +34,9 @@ -- 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 diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index fbdb14a438b..323afa4d62c 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -1749,7 +1749,14 @@ package body Sem_Ch10 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)) diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 09e9717f18b..4a954a1dc4b 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -543,22 +543,22 @@ package body Sem_Ch12 is -- 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 @@ -566,14 +566,14 @@ package body Sem_Ch12 is -- 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. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 83b209570ed..8ebf0c639e8 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2153,29 +2153,6 @@ package body Sem_Ch13 is 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 @@ -2602,6 +2579,9 @@ package body Sem_Ch13 is -------------------------- 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 @@ -2614,6 +2594,7 @@ package body Sem_Ch13 is 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 @@ -2627,85 +2608,92 @@ package body Sem_Ch13 is -- 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 | diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 227bb140446..d819cc4d106 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -33,6 +33,7 @@ with Exp_Util; use Exp_Util; 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; @@ -1002,7 +1003,64 @@ package body Sem_Ch5 is -- 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 @@ -1080,6 +1138,7 @@ package body Sem_Ch5 is Set_Etype (DS, Any_Type); end if; + Check_Controlled_Array_Attribute (DS); Make_Index (DS, LP); Set_Ekind (Id, E_Loop_Parameter); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 3f249c5428f..bd752a7fdde 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -4060,6 +4060,15 @@ package body Sem_Ch8 is 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); diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 22b8137ed39..368c22aa6af 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -930,6 +930,15 @@ package body Sinfo is 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 diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index fe94742e6e3..0e96df1a076 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -393,7 +393,7 @@ package Sinfo is -- 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" @@ -567,14 +567,18 @@ package Sinfo is -- 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. @@ -861,8 +865,16 @@ package Sinfo is -- 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 @@ -7107,6 +7119,9 @@ package Sinfo is 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 @@ -8491,6 +8506,7 @@ package Sinfo is 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); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 6ae6542c9b2..0ab0e473eb5 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -61,7 +61,7 @@ package body Sprint is 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 @@ -2782,10 +2782,11 @@ package body Sprint is 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)); diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index e5e95368392..5f4e6cabadc 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -96,8 +96,8 @@ package body Switch.C is 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; @@ -119,6 +119,14 @@ package body Switch.C is 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 @@ -637,6 +645,12 @@ package body Switch.C is 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' => diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index dad6005376b..76b1c3ebdb9 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -277,6 +277,11 @@ begin 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"); diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 72f5942cfae..d98e62ad050 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -1526,6 +1526,12 @@ package VMS_Data is -- -- 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 " & @@ -2809,6 +2815,7 @@ package VMS_Data is 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, |
