From 28ed91d40c6a1f579b76e546fa0ed42f8f28fd7b Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 15 Mar 2004 14:51:00 +0000 Subject: 2004-03-15 Jerome Guitton * 3zsoccon.ads: Fix multicast options. * s-thread.ads: Move unchecked conversion from ATSD_Access to Address in the spec. 2004-03-15 Robert Dewar * sem_prag.adb: Make sure No_Strict_Aliasing flag is set right when pragma used for a private type. * lib-xref.adb (Generate_Reference): Do not generate warning if reference is in a different unit from the pragma Unreferenced. * 5vtpopde.adb: Minor reformatting Fix casing of To_Task_ID * sem_ch13.adb (Validate_Unchecked_Conversion): Set No_Strict_Aliasing flag if we have an unchecked conversion to an access type in the same unit. 2004-03-15 Geert Bosch * a-ngcoty.adb (Modulus): In alternate formula for large real or imaginary parts, use Double precision throughout. * a-tifiio.adb (Put_Scaled): Remove remaining pragma Debug. Not only we want to be able to compile run-time with -gnata for testing, but this may also be instantiated in user code that is compiled with -gnata. 2004-03-15 Olivier Hainque * s-stalib.ads (Exception_Code): New type, to represent Import/Export codes. Having a separate type for this is useful to enforce consistency throughout the various run-time units. (Exception_Data): Use Exception_Code for Import_Code. * s-vmextra.ads, s-vmexta.adb: Use Exception_Code instead of a mix of Natural and Integer in various places. (Register_VMS_Exception): Use Base_Code_In to compute the exception code with the severity bits masked off. (Register_VMS_Exception): Handle the additional exception data pointer argument. * raise.c (_GNAT_Exception structure): Remove the handled_by_others component, now reflected by an exported accessor. (is_handled_by): New routine to compute whether the propagated occurrence matches some handler choice specification. Extracted out of get_action_description_for, and expanded to take care of the VMS specifities. (get_action_description_for): Use is_handled_by instead of an explicit complex condition to decide if the current choice at hand catches the propagated occurrence. * raise.h (Exception_Code): New type for C. * rtsfind.ads (RE_Id, RE_Unit_Table): Add System.Standard_Library.Exception_Code, to allow references from the pragma import/export expander. * a-exexpr.adb (Is_Handled_By_Others, Language_For, Import_Code_For): New accessors to allow easy access to GNAT exception data characteristics. (GNAT_GCC_Exception record, Propagate_Exception): Get rid of the redundant Handled_By_Others component, helper for the personality routine which will now be able to call the appropriate exception data accessor instead. * cstand.adb (Create_Standard): Adjust the type of the Import_Code component of Standard_Exception_Type to be the closest possible to Exception_Code in System.Standard_Library, that we cannot get at this point. Expand a ??? comment to notify that this type node should probably be rewritten later on. * exp_prag.adb (Expand_Pragma_Import_Export_Exception): Adjust the registration call to include a pointer to the exception object in the arguments. * init.c (__gnat_error_handler): Use Exception_Code and Base_Code_In instead of int and explicit bitmasks. 2004-03-15 Vincent Celier * vms_data.ads: Add new GNAT BIND qualifier /STATIC. Makes /NOSHARED equivalent to /STATIC and /NOSTATIC equivalent to /SHARED. * a-tasatt.adb (To_Access_Code): Remove this UC instantiation, no longer needed now that it is in the spec of System.Tasking.Task_Attributes. * adaint.h, adaint.c: (__gnat_create_output_file): New function * gnatcmd.adb: Fix bug introduced in previous rev: /= instead of = * g-os_lib.ads, g-os_lib.adb (Create_Output_Text_File): New function. * make.adb (Gnatmake): Do not check the executable suffix; it is being taken care of in Scan_Make_Arg. (Scan_Make_Arg): Add the executable suffix only if the argument following -o, in canonical case, does not end with the executable suffix. When in verbose mode and executable file name does not end with executable suffix, output the executable name, in canonical case. * s-tataat.ads (Access_Dummy_Wrapper): Add pragma No_Strict_Aliasing to avoid warnings when instantiating Ada.Task_Attributes. Minor reformating. * mlib-prj.adb (Process_Imported_Libraries): Get the imported libraries in the correct order. * prj-makr.adb (Process_Directory): No longer use GNAT.Expect, but redirect standard output and error to a file for the invocation of the compiler, then read the file. * prj-nmsc.adb (Find_Sources): Use the Display_Value for each directory, instead of the Value. (Find_Source_Dirs): Remove useless code & comments. 2004-03-15 Ed Schonberg * exp_ch3.adb (Freeze_Record_Type): If a primitive operation of a tagged type is inherited, and the parent operation is not frozen yet, force generation of a freeze node for the inherited operation, so the corresponding dispatch entry is properly initialized. (Make_Predefined_Primitive_Specs): Check that return type is Boolean when looking for user-defined equality operation. * exp_ch4.adb (Expand_Composite_Equality): Check that return type is boolean when locating primitive equality of tagged component. * exp_ch5.adb (Expand_Assign_Array): If the left-hand side is a bit-aligned field and the right-hand side a string literal, introduce a temporary before expanding assignment into a loop. * exp_ch9.adb (Expand_N_Task_Type_Declaration): Copy expression for priority in full, to ensure that any expanded subepxressions of it are elaborated in the scope of the init_proc. * exp_prag.adb (Expand_Pragma_Import): Search for initialization call after object declaration, skipping over code that may have been generated for validity checks. * sem_ch12.adb (Validate_Private_Type_Instance): If type has unknown discriminants, ignore the known discriminants of its full view, if any, to check legality. * sem_ch3.adb (Complete_Private_Subtype): Do not create constrained component if type has unknown discriminants. (Analyze_Private_Extension_Declaration): Discriminant constraint is null if type has unknown discriminants. * sem_ch6.adb (Analyze_Generic_Subprogram_Body): Generate reference for end label when present. * s-fileio.adb (Open): When called with a C_Stream, use given name for temporary file, rather than an empty string. 2004-03-15 Ed Falis * s-thread.adb: Removed, no longer used. 2004-03-15 Richard Kenner * decl.c (target.h): Now include. (gnat_to_gnu_entity, case E_Access_Type): Use mode derived from ESIZE in new build_pointer_from_mode calls for non-fat/non-thin pointer. (validate_size): For POINTER_TYPE, get smallest size permitted on machine. * fe.h: Sort Einfo decls and add Set_Mechanism. * Makefile.in: (LIBGNAT_SRCS): Remove types.h. (ada/decl.o): Depends on target.h. * trans.c (tree_transform, N_Unchecked_Type_Conversion): Do not use FUNCTION_BOUNDARY; always use TYPE_ALIGN. 2004-03-15 Thomas Quinot * 5ztpopsp.adb, 56tpopsp.adb: Fix spelling of Task_ID. * exp_ch4.adb (Expand_N_Indexed_Component): Do not call Insert_Dereference_Action when rewriting an implicit dereference into an explicit one, this will be taken care of during expansion of the explicit dereference. (Expand_N_Slice): Same. Always do the rewriting, even for the case of non-packed slices, since the dereference action generated by expansion of the explicit dereference is needed in any case. (Expand_N_Selected_Component): When rewriting an implicit dereference, analyze and resolve the rewritten explicit dereference so it is seen by the expander. (Insert_Dereference_Action): This procedure is now called only for the expansion of an N_Explcit_Dereference_Node. Do insert a check even for dereferences that do not come from source (including explicit dereferences resulting from rewriting implicit ones), but do not recursively insert a check for the dereference nodes contained within the check. (Insert_Dereference_Action): Clarify and correct comment. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@79494 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/prj-makr.adb | 404 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 255 insertions(+), 149 deletions(-) (limited to 'gcc/ada/prj-makr.adb') diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index efbbad2a0b8..dd16d034bcf 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,18 +34,26 @@ with Prj.Com; with Prj.Part; with Prj.PP; with Prj.Tree; use Prj.Tree; +with Prj.Util; use Prj.Util; with Snames; use Snames; with Table; use Table; with Ada.Characters.Handling; use Ada.Characters.Handling; with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with GNAT.Expect; use GNAT.Expect; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Regexp; use GNAT.Regexp; -with GNAT.Regpat; use GNAT.Regpat; package body Prj.Makr is + function Dup (Fd : File_Descriptor) return File_Descriptor; + pragma Import (C, Dup); + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); + pragma Import (C, Dup2); + + Gcc : constant String := "gcc"; + Gcc_Path : String_Access := null; + Non_Empty_Node : constant Project_Node_Id := 1; -- Used for the With_Clause of the naming project @@ -123,16 +131,7 @@ package body Prj.Makr is Source_List_FD : File_Descriptor; - Matcher : constant Pattern_Matcher := - Compile (Expression => "expected|Unit.*\)|No such"); - Args : Argument_List (1 .. Preproc_Switches'Length + 6); --- (1 => new String'("-c"), --- 2 => new String'("-gnats"), --- 3 => new String'("-gnatu"), --- 4 => new String'("-x"), --- 5 => new String'("ada"), --- 6 => null); type SFN_Pragma is record Unit : String_Access; @@ -164,13 +163,9 @@ package body Prj.Makr is Dir : Dir_Type; Process : Boolean := True; - begin - if Opt.Verbose_Mode then - Output.Write_Str ("Processing directory """); - Output.Write_Str (Dir_Name); - Output.Write_Line (""""); - end if; + Temp_File_Name : String_Access := null; + begin -- Avoid processing several times the same directory. for Index in 1 .. Processed_Directories.Last loop @@ -181,9 +176,16 @@ package body Prj.Makr is end loop; if Process then + if Opt.Verbose_Mode then + Output.Write_Str ("Processing directory """); + Output.Write_Str (Dir_Name); + Output.Write_Line (""""); + end if; + Processed_Directories. Increment_Last; Processed_Directories.Table (Processed_Directories.Last) := new String'(Dir_Name); + -- Get the source file names from the directory. -- Fails if the directory does not exist. @@ -248,158 +250,262 @@ package body Prj.Makr is if Matched = True then declare - PD : Process_Descriptor; - Result : Expect_Match; + FD : File_Descriptor; + Success : Boolean; + Saved_Output : File_Descriptor; + Saved_Error : File_Descriptor; begin + -- If we don't have yet the path of the compiler, + -- get it now. + + if Gcc_Path = null then + Gcc_Path := Locate_Exec_On_Path (Gcc); + + if Gcc_Path = null then + Prj.Com.Fail ("could not locate " & Gcc); + end if; + end if; + + -- If we don't have yet the file name of the + -- temporary file, get it now. + + if Temp_File_Name = null then + Create_Temp_File (FD, Temp_File_Name); + + if FD = Invalid_FD then + Prj.Com.Fail + ("could not create temporary file"); + end if; + + Close (FD); + Delete_File (Temp_File_Name.all, Success); + end if; + Args (Args'Last) := new String' - (Dir_Name & - Directory_Separator & - Str (1 .. Last)); + (Dir_Name & + Directory_Separator & + Str (1 .. Last)); + + -- Create the temporary file + + FD := Create_Output_Text_File + (Name => Temp_File_Name.all); + + if FD = Invalid_FD then + Prj.Com.Fail + ("could not create temporary file"); + end if; + + -- Save the standard output and error + + Saved_Output := Dup (Standout); + Saved_Error := Dup (Standerr); + + -- Set the standard output and error to the temporary + -- file. + + Dup2 (FD, Standout); + Dup2 (FD, Standerr); + + -- And spawn the compiler + + Spawn (Gcc_Path.all, Args, Success); + + -- Restore the standard output and error + Dup2 (Saved_Output, Standout); + Dup2 (Saved_Error, Standerr); + + -- Close the temporary file + + Close (FD); + + -- And close the saved standard output and error to + -- avoid too many file descriptors. + + Close (Saved_Output); + Close (Saved_Error); + + -- Now that standard output is restored, check if + -- the compiler ran correctly. + + -- Read the first line of the temporary file: + -- it should contain the kind and name of the unit. + + declare + File : Text_File; + Text_Line : String (1 .. 1_000); + Text_Last : Natural; begin - Non_Blocking_Spawn - (PD, "gcc", Args, Err_To_Out => True); - Expect (PD, Result, Matcher); + Open (File, Temp_File_Name.all); + + if not Is_Valid (File) then + Prj.Com.Fail + ("could not read temporary file"); + end if; - exception - when Process_Died => + if End_Of_File (File) then if Opt.Verbose_Mode then - Output.Write_Str ("(process died) "); + if not Success then + Output.Write_Str ("(process died) "); + end if; + + Output.Write_Line ("not a unit"); end if; - Result := Expect_Timeout; - end; + else + Get_Line (File, Text_Line, Text_Last); + Close (File); - if Result /= Expect_Timeout then + -- Now that we have read the line, delete the + -- temporary file, it is not needed anymore. + -- On VMS, this avoids several version of the + -- file, if it were only delete after all + -- sources were parsed. - -- If we got a unit name, this is a valid source - -- file. + Delete_File (Temp_File_Name.all, Success); - declare - S : constant String := Expect_Out_Match (PD); + -- Find the first closing parenthesis - begin - if S'Length >= 13 - and then S (S'First .. S'First + 3) = "Unit" - then - if Opt.Verbose_Mode then - Output.Write_Str - (S (S'Last - 4 .. S'Last - 1)); - Output.Write_Str (" of "); - Output.Write_Line - (S (S'First + 5 .. S'Last - 7)); + for J in 1 .. Text_Last loop + if Text_Line (J) = ')' then + Text_Last := J; + exit; end if; + end loop; + + declare + S : constant String := + Text_Line (1 .. Text_Last); + + begin + if S'Length >= 13 + and then S (S'First .. S'First + 3) = "Unit" + then + if Opt.Verbose_Mode then + Output.Write_Str + (S (S'Last - 4 .. S'Last - 1)); + Output.Write_Str (" of "); + Output.Write_Line + (S (S'First + 5 .. S'Last - 7)); + end if; - if Project_File then - - -- Add the corresponding attribute in the - -- Naming package of the naming project. - - declare - Decl_Item : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => - N_Declarative_Item); - - Attribute : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => - N_Attribute_Declaration); - - Expression : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Expression, - And_Expr_Kind => Single); - - Term : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Term, - And_Expr_Kind => Single); - - Value : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Literal_String, - And_Expr_Kind => Single); - - begin - Set_Next_Declarative_Item - (Decl_Item, - To => First_Declarative_Item_Of - (Naming_Package)); - Set_First_Declarative_Item_Of - (Naming_Package, To => Decl_Item); - Set_Current_Item_Node - (Decl_Item, To => Attribute); - - if - S (S'Last - 5 .. S'Last) = "(spec)" + if Project_File then + + -- Add the corresponding attribute in + -- the Naming package of the naming + -- project. + + declare + Decl_Item : constant Project_Node_Id + := Default_Project_Node + (Of_Kind => + N_Declarative_Item); + + Attribute : constant Project_Node_Id + := Default_Project_Node + (Of_Kind => + N_Attribute_Declaration); + + Expression : constant Project_Node_Id + := Default_Project_Node + (Of_Kind => N_Expression, + And_Expr_Kind => Single); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + And_Expr_Kind => Single); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Literal_String, + And_Expr_Kind => + Single); + + begin + Set_Next_Declarative_Item + (Decl_Item, + To => First_Declarative_Item_Of + (Naming_Package)); + Set_First_Declarative_Item_Of + (Naming_Package, To => Decl_Item); + Set_Current_Item_Node + (Decl_Item, To => Attribute); + + -- Is it a spec or a body? + + if S (S'Last - 5 .. S'Last) = + "(spec)" + then + Set_Name_Of + (Attribute, To => Name_Spec); + else + Set_Name_Of + (Attribute, + To => Name_Body); + end if; + + -- Get the name of the unit + + Name_Len := S'Last - S'First - 11; + Name_Buffer (1 .. Name_Len) := + (To_Lower + (S (S'First + 5 .. + S'Last - 7))); + Set_Associative_Array_Index_Of + (Attribute, To => Name_Find); + + Set_Expression_Of + (Attribute, To => Expression); + Set_First_Term + (Expression, To => Term); + Set_Current_Term (Term, To => Value); + + -- And set the name of the file + + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := + Str (1 .. Last); + Set_String_Value_Of + (Value, To => Name_Find); + end; + + -- Add source file name to source list + -- file. + + Last := Last + 1; + Str (Last) := ASCII.LF; + + if Write (Source_List_FD, + Str (1)'Address, + Last) /= Last then - Set_Name_Of - (Attribute, To => Name_Spec); - else - Set_Name_Of - (Attribute, - To => Name_Body); + Prj.Com.Fail ("disk full"); end if; - - Name_Len := S'Last - S'First - 11; - Name_Buffer (1 .. Name_Len) := - (To_Lower - (S (S'First + 5 .. S'Last - 7))); - Set_Associative_Array_Index_Of - (Attribute, To => Name_Find); - - Set_Expression_Of - (Attribute, To => Expression); - Set_First_Term (Expression, To => Term); - Set_Current_Term (Term, To => Value); - - Name_Len := Last; - Name_Buffer (1 .. Name_Len) := - Str (1 .. Last); - Set_String_Value_Of - (Value, To => Name_Find); - end; - - -- Add source file name to source list - -- file. - - Last := Last + 1; - Str (Last) := ASCII.LF; - - if Write (Source_List_FD, - Str (1)'Address, - Last) /= Last - then - Prj.Com.Fail ("disk full"); + else + -- Add an entry in the SFN_Pragmas + -- table. + + SFN_Pragmas.Increment_Last; + SFN_Pragmas.Table (SFN_Pragmas.Last) := + (Unit => new String' + (S (S'First + 5 .. S'Last - 7)), + File => new String'(Str (1 .. Last)), + Spec => S (S'Last - 5 .. S'Last) + = "(spec)"); end if; - else - -- Add an entry in the SFN_Pragmas table - - SFN_Pragmas.Increment_Last; - SFN_Pragmas.Table (SFN_Pragmas.Last) := - (Unit => new String' - (S (S'First + 5 .. S'Last - 7)), - File => new String'(Str (1 .. Last)), - Spec => S (S'Last - 5 .. S'Last) - = "(spec)"); - end if; - else - if Opt.Verbose_Mode then - Output.Write_Line ("not a unit"); + else + if Opt.Verbose_Mode then + Output.Write_Line ("not a unit"); + end if; end if; - end if; - end; - - else - if Opt.Verbose_Mode then - Output.Write_Line ("not a unit"); + end; end if; - end if; - - Close (PD); + end; end; else -- cgit v1.2.1