From: Arnaud Charlet Date: Thu, 8 Apr 2004 13:23:50 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=af15298919fc249fc35fc33144271c560c74939c;p=gcc.git [multiple changes] 2004-04-08 Richard Kenner * trans.c (tree_transform): Shortcut returning error_mark_node for statements in annotate_only_mode. (tree_transform, case N_Label, case N_Return_Statement, N_Goto_Statement): Make statement tree instead of generating code. (tree_transform, case N_Assignment_Statement): No longer check type_annotate_only. (gnat_expand_stmt, case GOTO_STMT, case LABEL_STMT, case RETURN_STMT): New. (first_nondeleted_insn, build_block_stmt, make_expr_stmt_from_rtl): New fcns. (gnat_to_gnu): Collect any RTL generated and deal with it. (tree_transform, case N_And_Then): Refine when have non-null RTL_EXPR. (tree_transform case N_If_Statement): Rewrite to make IF_STMT. (gnat_expand_stmt, case BLOCK_STMT, IF_STMT): New cases. * ada-tree.def (GOTO_STMT, LABEL_STMT, RETURN_STMT): New tree nodes. * ada-tree.def (EXPR_STMT): Fix typo in name. (BLOCK_STMT, IF_STMT): New nodes. * ada-tree.h (GOTO_STMT_LABEL, LABEL_STMT_LABEL, LABEL_STMT_FIRST_IN_EH): New macros. (RETURN_STMT_EXPR): Likewise. * ada-tree.h: (BLOCK_STMT_LIST, IF_STMT_COND, IF_STMT_TRUE, IF_STMT_ELSEIF, IF_STMT_ELSE): New macros. 2004-04-08 Thomas Quinot * atree.ads: Correct documentation on extended nodes. * link.c: Set run_path_option for FreeBSD. 2004-04-08 Vincent Celier * mlib-prj.adb (Build_Library.Check_Libs): On OpenVMS, if dec.ali is one of the ALI file, do not link with DEC lib. * par.adb Remove the last two characters ("%s" or "%b") when checking if a language defined unit may be recompiled. 2004-04-08 Ed Schonberg * sem_ch4.adb (Remove_Abstract_Operations): Improve error message when removal of abstract operation leaves no possible interpretation for expression. * sem_eval.adb (Eval_Qualified_Expression): Use Set_Raises_Constraint_Error on node when needed, so that it does not get optimized away by subsequent optimizations. * sem_res.adb (Resolve_Intrinsic_Operator): Save interpretations of operands even when they are not wrapped in a type conversion. 2004-04-08 Olivier Hainque * sem_prag.adb (Set_Exported): Warn about making static as result of export only when the export is coming from source. This may be not be true e.g. on VMS where we expand export pragmas for exception codes together with imported or exported exceptions, and we don't want the user to be warned about something he didn't write. 2004-04-08 Thomas Quinot * sem_util.adb (Note_Possible_Modification): Reorganize to remove code duplication between normal entities and those declared as renamings. No functional change. * s-fileio.ads (Form): Remove pragma Inline, as we cannot currently inline functions returning an unconstrained result. 2004-04-08 Eric Botcazou * utils.c (type_for_mode): Handle BLKmode and VOIDmode properly, to conform to what other front-ends do. 2004-04-08 Doug Rupp * 5vml-tgt.adb: Use Gas instead of VMS Macro to build auto init shared libraries. From-SVN: r80504 --- diff --git a/gcc/ada/5vml-tgt.adb b/gcc/ada/5vml-tgt.adb index f7479223f08..851ccf761b7 100644 --- a/gcc/ada/5vml-tgt.adb +++ b/gcc/ada/5vml-tgt.adb @@ -50,15 +50,10 @@ package body MLib.Tgt is -- Used to add the generated auto-init object files for auto-initializing -- stand-alone libraries. - Macro_Name : constant String := "macro"; + Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; -- The name of the command to invoke the macro-assembler - -- Options to use when invoking gcc to build the dynamic library - - No_Start_Files : aliased String := "-nostartfiles"; - - VMS_Options : Argument_List := - (No_Start_Files'Access, null); + VMS_Options : Argument_List := (1 .. 1 => null); Gnatsym_Name : constant String := "gnatsym"; @@ -272,7 +267,7 @@ package body MLib.Tgt is new String'("--for-linker=" & Opt_File_Name & "/OPTIONS"); end if; - VMS_Options (VMS_Options'First + 1) := For_Linker_Opt; + VMS_Options (VMS_Options'First) := For_Linker_Opt; for J in Inter'Range loop To_Lower (Inter (J).all); @@ -293,7 +288,7 @@ package body MLib.Tgt is if Auto_Init then declare - Macro_File_Name : constant String := Lib_Filename & "$init.mar"; + Macro_File_Name : constant String := Lib_Filename & "$init.asm"; Macro_File : Ada.Text_IO.File_Type; Init_Proc : String := Lib_Filename & "INIT"; Popen_Result : System.Address; @@ -319,13 +314,12 @@ package body MLib.Tgt is begin Create (Macro_File, Out_File, Macro_File_Name); - Put_Line (Macro_File, ASCII.HT & ".EXTRN LIB$INITIALIZE"); - Put_Line (Macro_File, ASCII.HT & ".EXTRN " & Init_Proc); Put_Line (Macro_File, - ASCII.HT & ".PSECT LIB$INITIALIZE USR,GBL,NOEXE,NOWRT,LONG"); - Put_Line (Macro_File, ASCII.HT & ".ADDRESS " & Init_Proc); - Put_Line (Macro_File, ASCII.HT & ".END"); + ASCII.HT & ".section LIB$INITIALIZE,GBL,NOWRT"); + Put_Line + (Macro_File, + ASCII.HT & ".long " & Init_Proc); Close (Macro_File); diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5ca1aeb4b00..0a24bc008c9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,86 @@ +2004-04-08 Richard Kenner + + * trans.c (tree_transform): Shortcut returning error_mark_node for + statements in annotate_only_mode. + (tree_transform, case N_Label, case N_Return_Statement, + N_Goto_Statement): Make statement tree instead of generating code. + (tree_transform, case N_Assignment_Statement): No longer check + type_annotate_only. + (gnat_expand_stmt, case GOTO_STMT, case LABEL_STMT, case + RETURN_STMT): New. + (first_nondeleted_insn, build_block_stmt, make_expr_stmt_from_rtl): + New fcns. + (gnat_to_gnu): Collect any RTL generated and deal with it. + (tree_transform, case N_And_Then): Refine when have non-null RTL_EXPR. + (tree_transform case N_If_Statement): Rewrite to make IF_STMT. + (gnat_expand_stmt, case BLOCK_STMT, IF_STMT): New cases. + + * ada-tree.def (GOTO_STMT, LABEL_STMT, RETURN_STMT): New tree nodes. + + * ada-tree.def (EXPR_STMT): Fix typo in name. + (BLOCK_STMT, IF_STMT): New nodes. + + * ada-tree.h (GOTO_STMT_LABEL, LABEL_STMT_LABEL, + LABEL_STMT_FIRST_IN_EH): New macros. + (RETURN_STMT_EXPR): Likewise. + + * ada-tree.h: (BLOCK_STMT_LIST, IF_STMT_COND, IF_STMT_TRUE, + IF_STMT_ELSEIF, IF_STMT_ELSE): New macros. + +2004-04-08 Thomas Quinot + + * atree.ads: Correct documentation on extended nodes. + + * link.c: Set run_path_option for FreeBSD. + +2004-04-08 Vincent Celier + + * mlib-prj.adb (Build_Library.Check_Libs): On OpenVMS, if dec.ali is + one of the ALI file, do not link with DEC lib. + + * par.adb Remove the last two characters ("%s" or "%b") when checking + if a language defined unit may be recompiled. + +2004-04-08 Ed Schonberg + + * sem_ch4.adb (Remove_Abstract_Operations): Improve error message when + removal of abstract operation leaves no possible interpretation for + expression. + + * sem_eval.adb (Eval_Qualified_Expression): Use + Set_Raises_Constraint_Error on node when needed, so that it does not + get optimized away by subsequent optimizations. + + * sem_res.adb (Resolve_Intrinsic_Operator): Save interpretations of + operands even when they are not wrapped in a type conversion. + +2004-04-08 Olivier Hainque + + * sem_prag.adb (Set_Exported): Warn about making static as result of + export only when the export is coming from source. This may be not + be true e.g. on VMS where we expand export pragmas for exception codes + together with imported or exported exceptions, and we don't want the + user to be warned about something he didn't write. + +2004-04-08 Thomas Quinot + + * sem_util.adb (Note_Possible_Modification): Reorganize to remove code + duplication between normal entities and those declared as renamings. + No functional change. + + * s-fileio.ads (Form): Remove pragma Inline, as we cannot currently + inline functions returning an unconstrained result. + +2004-04-08 Eric Botcazou + + * utils.c (type_for_mode): Handle BLKmode and VOIDmode properly, to + conform to what other front-ends do. + +2004-04-08 Doug Rupp + + * 5vml-tgt.adb: Use Gas instead of VMS Macro to build auto init shared + libraries. + 2004-04-06 Pascal Obry * adaint.c (DIR_SEPARATOR): Properly set DIR_SEPARATOR on Win32. diff --git a/gcc/ada/ada-tree.def b/gcc/ada/ada-tree.def index 08a69acd21f..e58963ed20a 100644 --- a/gcc/ada/ada-tree.def +++ b/gcc/ada/ada-tree.def @@ -84,4 +84,26 @@ DEFTREECODE (GNAT_LOOP_ID, "gnat_loop_id", 'x', 0) We start with an expression statement, whose only operand is an expression, EXPR_STMT_EXPR, Execution of the statement means evaluation of the expression (such as a MODIFY_EXPR) and discarding its result. */ -DEFTREECODE (EXPR_STMT, "expr_stmt_expr", 's', 1) +DEFTREECODE (EXPR_STMT, "expr_stmt", 's', 1) + +/* This represents a list of statements. BLOCK_STMT_LIST is a list + statement tree, chained via TREE_CHAIN. */ +DEFTREECODE (BLOCK_STMT, "block_stmt", 's', 1) + +/* This is an IF statement. IF_STMT_COND is the condition being tested, + IF_STMT_TRUE is the statement to be executed if the condition is + true; IF_STMT_ELSEIF, if non-null, is a list of more IF_STMT nodes (where + we only look at IF_STMT_COND and IF_STMT_TRUE) that correspond to + any "else if" parts; and IF_STMT_ELSE is the statement to be executed if + all conditions are. */ +DEFTREECODE (IF_STMT, "if_stmt", 's', 4) + +/* A goto just points to the label: GOTO_STMT_LABEL. */ +DEFTREECODE (GOTO_STMT, "goto_stmt", 's', 1) + +/* A label: LABEL_STMT_LABEL is the label and LABEL_STMT_FIRST_IN_EH is set + if this is the first label of an exception handler. */ +DEFTREECODE (LABEL_STMT, "label_stmt", 's', 1) + +/* A "return". RETURN_STMT_EXPR is the value to return if non-null. */ +DEFTREECODE (RETURN_STMT, "return_stmt", 's', 1) diff --git a/gcc/ada/ada-tree.h b/gcc/ada/ada-tree.h index aa256dc51e1..572a5b72e29 100644 --- a/gcc/ada/ada-tree.h +++ b/gcc/ada/ada-tree.h @@ -294,5 +294,15 @@ struct lang_type GTY(()) /* We store the Sloc in statement nodes. */ #define TREE_SLOC(NODE) TREE_COMPLEXITY (STMT_CHECK (NODE)) -/* There is just one field in an EXPR_STMT: the expression. */ #define EXPR_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXPR_STMT, 0) +#define BLOCK_STMT_LIST(NODE) TREE_OPERAND_CHECK_CODE (NODE, BLOCK_STMT, 0) +#define IF_STMT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 0) +#define IF_STMT_TRUE(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 1) +#define IF_STMT_ELSEIF(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 2) +#define IF_STMT_ELSE(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 3) +#define GOTO_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, GOTO_STMT, 0) +#define LABEL_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, LABEL_STMT, 0) +#define LABEL_STMT_FIRST_IN_EH(NODE) \ + (LABEL_STMT_CHECK (NODE)->common.unsigned_flag) +#define RETURN_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, RETURN_STMT, 0) + diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 501c1830fa4..0f38e3ee491 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -495,7 +495,7 @@ package Atree is function Extend_Node (Node : Node_Id) return Entity_Id; -- This function returns a copy of its input node with an extension -- added. The fields of the extension are set to Empty. Due to the way - -- extensions are handled (as two consecutive array elements), it may + -- extensions are handled (as four consecutive array elements), it may -- be necessary to reallocate the node, so that the returned value is -- not the same as the input value, but where possible the returned -- value will be the same as the input value (i.e. the extension will diff --git a/gcc/ada/link.c b/gcc/ada/link.c index dd20d03b10d..e16978eca3e 100644 --- a/gcc/ada/link.c +++ b/gcc/ada/link.c @@ -156,7 +156,7 @@ const char *object_library_extension = ".a"; #elif defined (__FreeBSD__) char *object_file_option = ""; -char *run_path_option = ""; +char *run_path_option = "-Wl,-rpath,"; char shared_libgnat_default = STATIC; int link_max = 2147483647; unsigned char objlist_file_supported = 0; diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 4b82ffaef04..612845c7f1f 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -308,6 +308,9 @@ package body MLib.Prj is Libdecgnat_Needed : Boolean := False; -- On OpenVMS, set to True if library needs to be linked with libdecgnat + Check_Libdecgnat : Boolean := Hostparm.OpenVMS; + -- Set to False if package Dec is part of the library sources. + Data : Project_Data := Projects.Table (For_Project); Object_Directory_Path : constant String := @@ -372,7 +375,8 @@ package body MLib.Prj is -- to link with -lgnarl (this is the case when there is a dependency -- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file -- indicates that there is a need to link with -ldecgnat (this is the - -- case when there is a dependency on dec.ads). + -- case when there is a dependency on dec.ads, except when it is the + -- DEC library, the one that contains package DEC). procedure Process (The_ALI : File_Name_Type); -- Check if the closure of a library unit which is or should be in the @@ -504,12 +508,17 @@ package body MLib.Prj is Text : Text_Buffer_Ptr; Id : ALI.ALI_Id; - pragma Warnings (Off, Id); - -- Comment needed ??? - begin + -- On OpenVMS, if we have package DEC, it means this is the DEC lib: + -- no need to link with itself. + + if Check_Libdecgnat and then ALI_File = "dec.ali" then + Check_Libdecgnat := False; + Libdecgnat_Needed := False; + end if; + if not Libgnarl_Needed or - (Hostparm.OpenVMS and then (not Libdecgnat_Needed)) + (Check_Libdecgnat and then (not Libdecgnat_Needed)) then -- Scan the ALI file @@ -526,7 +535,7 @@ package body MLib.Prj is Read_Lines => "D"); Free (Text); - -- Look for s-osinte.ads in the dependencies + -- Look for s-osinte.ads and dec.ads in the dependencies for Index in ALI.ALIs.Table (Id).First_Sdep .. ALI.ALIs.Table (Id).Last_Sdep @@ -534,7 +543,7 @@ package body MLib.Prj is if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then Libgnarl_Needed := True; - elsif Hostparm.OpenVMS and then + elsif Check_Libdecgnat and then ALI.Sdep.Table (Index).Sfile = S_Dec_Ads then Libdecgnat_Needed := True; @@ -1941,7 +1950,10 @@ package body MLib.Prj is end if; Status := fclose (Fd); - -- Is it really right to ignore any close error ??? + + -- It is safe to ignore any error when closing, because the file was + -- only opened for reading. + end Process_Binder_File; ------------------ diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index dbec0b8ff26..2d86577a48c 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -1310,16 +1310,24 @@ begin and then not GNAT_Mode then declare - Name : constant String := - Get_Name_String - (Unit_Name (Current_Source_Unit)); + Uname : constant String := + Get_Name_String + (Unit_Name (Current_Source_Unit)); + Name : String (1 .. Uname'Length - 2); + begin - if (Name = "ada" or else - Name = "calendar" or else - Name = "interfaces" or else - Name = "system" or else - Name = "machine_code" or else - Name = "unchecked_conversion" or else + -- Because Unit_Name includes "%s" or "%b", we need to + -- strip the last two characters to get the real unit + -- name. + + Name := Uname (Uname'First .. Uname'Last - 2); + + if (Name = "ada" or else + Name = "calendar" or else + Name = "interfaces" or else + Name = "system" or else + Name = "machine_code" or else + Name = "unchecked_conversion" or else Name = "unchecked_deallocation" or else (Name'Length > 4 and then diff --git a/gcc/ada/s-fileio.ads b/gcc/ada/s-fileio.ads index fe06807d165..dbbc8bfa391 100644 --- a/gcc/ada/s-fileio.ads +++ b/gcc/ada/s-fileio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2002, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- @@ -250,7 +250,6 @@ package System.File_IO is private pragma Inline (Check_Read_Status); pragma Inline (Check_Write_Status); - pragma Inline (Form); pragma Inline (Mode); end System.File_IO; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 9388125aaf1..2b958a839c9 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4332,7 +4332,7 @@ package body Sem_Ch4 is procedure Remove_Abstract_Operations (N : Node_Id) is I : Interp_Index; It : Interp; - Has_Abstract_Op : Boolean := False; + Abstract_Op : Entity_Id := Empty; -- AI-310: If overloaded, remove abstract non-dispatching -- operations. @@ -4347,7 +4347,7 @@ package body Sem_Ch4 is and then Is_Abstract (It.Nam) and then not Is_Dispatching_Operation (It.Nam) then - Has_Abstract_Op := True; + Abstract_Op := It.Nam; Remove_Interp (I); exit; end if; @@ -4359,7 +4359,7 @@ package body Sem_Ch4 is -- always added to the overload set, unless it is a universal -- operation. - if not Has_Abstract_Op then + if No (Abstract_Op) then return; elsif Nkind (N) in N_Op then @@ -4398,10 +4398,9 @@ package body Sem_Ch4 is begin if Present (Universal_Interpretation (Arg1)) - or else - (Present (Next (Arg1)) - and then - Present (Universal_Interpretation (Next (Arg1)))) + and then + (No (Next (Arg1)) + or else Present (Universal_Interpretation (Next (Arg1)))) then return; @@ -4417,6 +4416,23 @@ package body Sem_Ch4 is end if; end; end if; + + -- If the removal has left no valid interpretations, emit + -- error message now an label node as illegal. + + if Present (Abstract_Op) then + Get_First_Interp (N, I, It); + + if No (It.Nam) then + + -- Removal of abstract operation left no viable candidate. + + Set_Etype (N, Any_Type); + Error_Msg_Sloc := Sloc (Abstract_Op); + Error_Msg_NE + ("cannot call abstract operation& declared#", N, Abstract_Op); + end if; + end if; end if; end Remove_Abstract_Operations; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index f884854f906..9c203101342 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -1947,6 +1947,13 @@ package body Sem_Eval is or else Nkind (Parent (N)) = N_Allocator then Check_Non_Static_Context (Operand); + + -- If operand is known to raise constraint_error, set the + -- flag on the expression so it does not get optimized away. + + if Nkind (Operand) = N_Raise_Constraint_Error then + Set_Raises_Constraint_Error (N); + end if; return; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 3c8ca3df41b..ea1eab3405a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3555,7 +3555,15 @@ package body Sem_Prag is Set_Is_Public (E); Set_Is_Statically_Allocated (E); - if Warn_On_Export_Import then + -- Warn if the corresponding W flag is set and the pragma + -- comes from source. The latter may be not be true e.g. on + -- VMS where we expand export pragmas for exception codes + -- associated with imported or exported exceptions. We don't + -- want the user to be warned about something he didn't write. + + if Warn_On_Export_Import + and then Comes_From_Source (Arg) + then Error_Msg_NE ("?& has been made static as a result of Export", Arg, E); Error_Msg_N diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index c05b81b304c..103ebfdd947 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4965,6 +4965,7 @@ package body Sem_Res is end loop; Set_Entity (N, Op); + Set_Is_Overloaded (N, False); -- If the operand type is private, rewrite with suitable -- conversions on the operands and the result, to expose @@ -4993,17 +4994,21 @@ package body Sem_Res is or else Typ /= Etype (Right_Opnd (N)) then -- Add explicit conversion where needed, and save interpretations - -- if operands are overloaded. + -- in case operands are overloaded. - Arg1 := Convert_To (Typ, Left_Opnd (N)); + Arg1 := Convert_To (Typ, Left_Opnd (N)); Arg2 := Convert_To (Typ, Right_Opnd (N)); if Nkind (Arg1) = N_Type_Conversion then Save_Interps (Left_Opnd (N), Expression (Arg1)); + else + Save_Interps (Left_Opnd (N), Arg1); end if; if Nkind (Arg2) = N_Type_Conversion then Save_Interps (Right_Opnd (N), Expression (Arg2)); + else + Save_Interps (Right_Opnd (N), Arg1); end if; Rewrite (Left_Opnd (N), Arg1); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 578c9340f94..a3adc6ed3cb 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4985,41 +4985,12 @@ package body Sem_Util is Ent : Entity_Id; Exp : Node_Id; - procedure Set_Ref (E : Entity_Id; N : Node_Id); - -- Internal routine to note modification on entity E by node N - -- Has no effect if entity E does not represent an object. - - ------------- - -- Set_Ref -- - ------------- - - procedure Set_Ref (E : Entity_Id; N : Node_Id) is - begin - if Is_Object (E) then - if Comes_From_Source (N) - or else Modification_Comes_From_Source - then - Set_Never_Set_In_Source (E, False); - end if; - - Set_Is_True_Constant (E, False); - Set_Current_Value (E, Empty); - Generate_Reference (E, N, 'm'); - Kill_Checks (E); - - if not Can_Never_Be_Null (E) then - Set_Is_Known_Non_Null (E, False); - end if; - end if; - end Set_Ref; - - -- Start of processing for Note_Possible_Modification - begin -- Loop to find referenced entity, if there is one Exp := N; loop + <> Ent := Empty; if Is_Entity_Name (Exp) then @@ -5074,10 +5045,14 @@ package body Sem_Util is -- Now look for entity being referenced if Present (Ent) then - if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) - and then Present (Renamed_Object (Ent)) - then - Set_Never_Set_In_Source (Ent, False); + + if Is_Object (Ent) then + if Comes_From_Source (Exp) + or else Modification_Comes_From_Source + then + Set_Never_Set_In_Source (Ent, False); + end if; + Set_Is_True_Constant (Ent, False); Set_Current_Value (Ent, Empty); @@ -5085,13 +5060,18 @@ package body Sem_Util is Set_Is_Known_Non_Null (Ent, False); end if; - Exp := Renamed_Object (Ent); + if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) + and then Present (Renamed_Object (Ent)) + then + Exp := Renamed_Object (Ent); + goto Continue; + end if; - else - Set_Ref (Ent, Exp); - Kill_Checks (Ent); - return; + Generate_Reference (Ent, Exp, 'm'); end if; + + Kill_Checks (Ent); + return; end if; end loop; end Note_Possible_Modification; diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index efa99fe0169..8b24761c3a5 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -104,6 +104,9 @@ Node_Id error_gnat_node; static GTY(()) tree gnu_return_label_stack; static tree tree_transform (Node_Id); +static rtx first_nondeleted_insn (rtx); +static tree build_block_stmt (List_Id); +static tree make_expr_stmt_from_rtl (rtx, Node_Id); static void elaborate_all_entities (Node_Id); static void process_freeze_entity (Node_Id); static void process_inlined_subprograms (Node_Id); @@ -255,15 +258,60 @@ tree gnat_to_gnu (Node_Id gnat_node) { tree gnu_root; + bool made_sequence = false; + + /* We support the use of this on statements now as a transition + to full function-at-a-time processing. So we need to see if anything + we do generates RTL and returns error_mark_node. */ + if (!global_bindings_p ()) + { + start_sequence (); + emit_note (NOTE_INSN_DELETED); + made_sequence = true; + } /* Save node number in case error */ error_gnat_node = gnat_node; gnu_root = tree_transform (gnat_node); - /* If we got no code as a result, something is wrong. */ - if (gnu_root == error_mark_node && ! type_annotate_only) - gigi_abort (303); + if (gnu_root == error_mark_node) + { + if (!made_sequence) + { + if (type_annotate_only) + return gnu_root; + else + gigi_abort (303); + } + + gnu_root = make_expr_stmt_from_rtl (first_nondeleted_insn (get_insns ()), + gnat_node); + end_sequence (); + } + else if (made_sequence) + { + rtx insns = first_nondeleted_insn (get_insns ()); + + end_sequence (); + + if (insns) + { + /* If we have a statement, we need to first evaluate any RTL we + made in the process of building it and then the statement. */ + if (IS_STMT (gnu_root)) + { + tree gnu_expr_stmt = make_expr_stmt_from_rtl (insns, gnat_node); + + TREE_CHAIN (gnu_expr_stmt) = gnu_root; + gnu_root = build_nt (BLOCK_STMT, gnu_expr_stmt); + TREE_TYPE (gnu_root) = void_type_node; + TREE_SLOC (gnu_root) = Sloc (gnat_node); + } + else + emit_insn (insns); + } + } return gnu_root; } @@ -290,6 +338,10 @@ tree_transform (Node_Id gnat_node) /* Set input_file_name and lineno from the Sloc in the GNAT tree. */ set_lineno (gnat_node, 0); + if (IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call) + && type_annotate_only) + return error_mark_node; + /* If this is a Statement and we are at top level, we add the statement as an elaboration for a null tree. That will cause it to be placed in the elaboration procedure. */ @@ -1795,7 +1847,7 @@ tree_transform (Node_Id gnat_node) gnu_result_type = get_unpadded_type (Etype (gnat_node)); - if (RTL_EXPR_SEQUENCE (gnu_rhs_side) != 0) + if (first_nondeleted_insn (RTL_EXPR_SEQUENCE (gnu_rhs_side))) gnu_rhs = build (COMPOUND_EXPR, gnu_result_type, gnu_rhs_side, gnu_rhs); @@ -2020,31 +2072,17 @@ tree_transform (Node_Id gnat_node) /***************************/ case N_Label: - if (! type_annotate_only) - { - tree gnu_label = gnat_to_gnu (Identifier (gnat_node)); - Node_Id gnat_parent = Parent (gnat_node); - - expand_label (gnu_label); - - /* If this is the first label of an exception handler, we must - mark that any CALL_INSN can jump to it. */ - if (Present (gnat_parent) - && Nkind (gnat_parent) == N_Exception_Handler - && First (Statements (gnat_parent)) == gnat_node) - nonlocal_goto_handler_labels - = gen_rtx_EXPR_LIST (VOIDmode, label_rtx (gnu_label), - nonlocal_goto_handler_labels); - } + gnu_result = build_nt (LABEL_STMT, gnat_to_gnu (Identifier (gnat_node))); + LABEL_STMT_FIRST_IN_EH (gnu_result) + = (Present (Parent (gnat_node)) + && Nkind (Parent (gnat_node)) == N_Exception_Handler + && First (Statements (Parent (gnat_node))) == gnat_node); break; case N_Null_Statement: break; case N_Assignment_Statement: - if (type_annotate_only) - break; - /* Get the LHS and RHS of the statement and convert any reference to an unconstrained array into a reference to the underlying array. */ gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node))); @@ -2071,53 +2109,28 @@ tree_transform (Node_Id gnat_node) break; case N_If_Statement: - /* Start an IF statement giving the condition. */ - gnu_expr = gnat_to_gnu (Condition (gnat_node)); - set_lineno (gnat_node, 1); - expand_start_cond (gnu_expr, 0); - - /* Generate code for the statements to be executed if the condition - is true. */ + gnu_result = NULL_TREE; - for (gnat_temp = First (Then_Statements (gnat_node)); - Present (gnat_temp); - gnat_temp = Next (gnat_temp)) - gnat_to_code (gnat_temp); - - /* Generate each of the "else if" parts. */ + /* Make an IF_STMT for each of the "else if" parts. */ if (Present (Elsif_Parts (gnat_node))) - { - for (gnat_temp = First (Elsif_Parts (gnat_node)); - Present (gnat_temp); - gnat_temp = Next (gnat_temp)) - { - Node_Id gnat_statement; - - expand_start_else (); - - /* Set up the line numbers for each condition we test. */ - set_lineno (Condition (gnat_temp), 1); - expand_elseif (gnat_to_gnu (Condition (gnat_temp))); - - for (gnat_statement = First (Then_Statements (gnat_temp)); - Present (gnat_statement); - gnat_statement = Next (gnat_statement)) - gnat_to_code (gnat_statement); - } - } - - /* Finally, handle any statements in the "else" part. */ - if (Present (Else_Statements (gnat_node))) - { - expand_start_else (); - - for (gnat_temp = First (Else_Statements (gnat_node)); - Present (gnat_temp); - gnat_temp = Next (gnat_temp)) - gnat_to_code (gnat_temp); - } + for (gnat_temp = First (Elsif_Parts (gnat_node)); + Present (gnat_temp); gnat_temp = Next (gnat_temp)) + { + tree gnu_elseif + = build_nt (IF_STMT, gnat_to_gnu (Condition (gnat_temp)), + build_block_stmt (Then_Statements (gnat_temp)), + NULL_TREE, NULL_TREE); + + TREE_SLOC (gnu_elseif) = Sloc (Condition (gnat_temp)); + TREE_CHAIN (gnu_elseif) = gnu_result; + TREE_TYPE (gnu_elseif) = void_type_node; + gnu_result = gnu_elseif; + } - expand_end_cond (); + gnu_result = build_nt (IF_STMT, gnat_to_gnu (Condition (gnat_node)), + build_block_stmt (Then_Statements (gnat_node)), + nreverse (gnu_result), + build_block_stmt (Else_Statements (gnat_node))); break; case N_Case_Statement: @@ -2456,9 +2469,6 @@ tree_transform (Node_Id gnat_node) break; case N_Return_Statement: - if (type_annotate_only) - break; - { /* The gnu function type of the subprogram currently processed. */ tree gnu_subprog_type = TREE_TYPE (current_function_decl); @@ -2478,7 +2488,11 @@ tree_transform (Node_Id gnat_node) a branch to that label. */ if (TREE_VALUE (gnu_return_label_stack) != 0) - expand_goto (TREE_VALUE (gnu_return_label_stack)); + { + gnu_result = build_nt (GOTO_STMT, + TREE_VALUE (gnu_return_label_stack)); + break; + } else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE) { @@ -2538,25 +2552,12 @@ tree_transform (Node_Id gnat_node) } } - set_lineno (gnat_node, 1); - if (gnu_ret_val) - expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE, - DECL_RESULT (current_function_decl), - gnu_ret_val)); - else - expand_null_return (); - + gnu_result = build_nt (RETURN_STMT, gnu_ret_val); } break; case N_Goto_Statement: - if (type_annotate_only) - break; - - gnu_expr = gnat_to_gnu (Name (gnat_node)); - TREE_USED (gnu_expr) = 1; - set_lineno (gnat_node, 1); - expand_goto (gnu_expr); + gnu_result = build_nt (GOTO_STMT, gnat_to_gnu (Name (gnat_node))); break; /****************************/ @@ -4174,12 +4175,70 @@ tree_transform (Node_Id gnat_node) return gnu_result; } +/* INSN is a list of insns. Return the first rtl in the list that isn't + an INSN_NOTE_DELETED. */ + +static rtx +first_nondeleted_insn (rtx insns) +{ + for (; insns && GET_CODE (insns) == NOTE + && NOTE_LINE_NUMBER (insns) == NOTE_INSN_DELETED; + insns = NEXT_INSN (insns)) + ; + + return insns; +} + +/* Build a BLOCK_STMT from GNAT_LIST, a possibly-empty list of statements. */ + +static tree +build_block_stmt (List_Id gnat_list) +{ + tree gnu_result = NULL_TREE; + Node_Id gnat_node; + + if (No (gnat_list) || Is_Empty_List (gnat_list)) + return NULL_TREE; + + for (gnat_node = First (gnat_list); + Present (gnat_node); + gnat_node = Next (gnat_node)) + gnu_result = chainon (gnat_to_gnu (gnat_node), gnu_result); + + gnu_result = build_nt (BLOCK_STMT, nreverse (gnu_result)); + TREE_SLOC (gnu_result) = TREE_SLOC (BLOCK_STMT_LIST (gnu_result)); + TREE_TYPE (gnu_result) = void_type_node; + return gnu_result; +} + +/* Build an EXPR_STMT to evaluate INSNS. Use Sloc from GNAT_NODE. */ + +static tree +make_expr_stmt_from_rtl (rtx insns, Node_Id gnat_node) +{ + tree gnu_result = make_node (RTL_EXPR); + + TREE_TYPE (gnu_result) = void_type_node; + RTL_EXPR_RTL (gnu_result) = RTL_EXPR_ALT_RTL (gnu_result) = const0_rtx; + RTL_EXPR_SEQUENCE (gnu_result) = insns; + rtl_expr_chain = tree_cons (NULL_TREE, gnu_result, rtl_expr_chain); + + gnu_result = build_nt (EXPR_STMT, gnu_result); + TREE_SLOC (gnu_result) = Sloc (gnat_node); + TREE_TYPE (gnu_result) = void_type_node; + + return gnu_result; +} + /* GNU_STMT is a statement. We generate code for that statement. */ void gnat_expand_stmt (tree gnu_stmt) { - set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1); + tree gnu_elmt; + + if (TREE_SLOC (gnu_stmt)) + set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1); switch (TREE_CODE (gnu_stmt)) { @@ -4187,6 +4246,59 @@ gnat_expand_stmt (tree gnu_stmt) expand_expr_stmt (EXPR_STMT_EXPR (gnu_stmt)); break; + case BLOCK_STMT: + for (gnu_elmt = BLOCK_STMT_LIST (gnu_stmt); gnu_elmt; + gnu_elmt = TREE_CHAIN (gnu_elmt)) + expand_expr_stmt (gnu_elmt); + break; + + case IF_STMT: + expand_start_cond (IF_STMT_COND (gnu_stmt), 0); + + if (IF_STMT_TRUE (gnu_stmt)) + expand_expr_stmt (IF_STMT_TRUE (gnu_stmt)); + + for (gnu_elmt = IF_STMT_ELSEIF (gnu_stmt); gnu_elmt; + gnu_elmt = TREE_CHAIN (gnu_elmt)) + { + expand_start_else (); + set_lineno_from_sloc (TREE_SLOC (gnu_elmt), 1); + expand_elseif (IF_STMT_COND (gnu_elmt)); + expand_expr_stmt (IF_STMT_TRUE (gnu_elmt)); + } + + if (IF_STMT_ELSE (gnu_stmt)) + { + expand_start_else (); + expand_expr_stmt (IF_STMT_ELSE (gnu_stmt)); + } + + expand_end_cond (); + break; + + case GOTO_STMT: + TREE_USED (GOTO_STMT_LABEL (gnu_stmt)) = 1; + expand_goto (GOTO_STMT_LABEL (gnu_stmt)); + break; + + case LABEL_STMT: + expand_label (LABEL_STMT_LABEL (gnu_stmt)); + if (LABEL_STMT_FIRST_IN_EH (gnu_stmt)) + nonlocal_goto_handler_labels + = gen_rtx_EXPR_LIST (VOIDmode, + label_rtx (LABEL_STMT_LABEL (gnu_stmt)), + nonlocal_goto_handler_labels); + break; + + case RETURN_STMT: + if (RETURN_STMT_EXPR (gnu_stmt)) + expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE, + DECL_RESULT (current_function_decl), + RETURN_STMT_EXPR (gnu_stmt))); + else + expand_null_return (); + break; + default: abort (); } diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c index 1cefff8266c..8b0bf8183dd 100644 --- a/gcc/ada/utils.c +++ b/gcc/ada/utils.c @@ -2069,7 +2069,11 @@ float_type_for_precision (int precision, enum machine_mode mode) tree gnat_type_for_mode (enum machine_mode mode, int unsignedp) { - if (GET_MODE_CLASS (mode) == MODE_FLOAT) + if (mode == BLKmode) + return NULL_TREE; + else if (mode == VOIDmode) + return void_type_node; + else if (GET_MODE_CLASS (mode) == MODE_FLOAT) return float_type_for_precision (GET_MODE_PRECISION (mode), mode); else return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);