diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/5vml-tgt.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/ChangeLog | 83 | ||||
| -rw-r--r-- | gcc/ada/ada-tree.def | 24 | ||||
| -rw-r--r-- | gcc/ada/ada-tree.h | 12 | ||||
| -rw-r--r-- | gcc/ada/atree.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/link.c | 2 | ||||
| -rw-r--r-- | gcc/ada/mlib-prj.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/par.adb | 26 | ||||
| -rw-r--r-- | gcc/ada/s-fileio.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 58 | ||||
| -rw-r--r-- | gcc/ada/trans.c | 286 | ||||
| -rw-r--r-- | gcc/ada/utils.c | 6 |
16 files changed, 434 insertions, 174 deletions
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 <kenner@vlsi1.ultra.nyu.edu> + + * 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 <quinot@act-europe.fr> + + * atree.ads: Correct documentation on extended nodes. + + * link.c: Set run_path_option for FreeBSD. + +2004-04-08 Vincent Celier <celier@gnat.com> + + * 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 <schonberg@gnat.com> + + * 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 <hainque@act-europe.fr> + + * 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 <quinot@act-europe.fr> + + * 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 <ebotcazou@act-europe.fr> + + * utils.c (type_for_mode): Handle BLKmode and VOIDmode properly, to + conform to what other front-ends do. + +2004-04-08 Doug Rupp <rupp@gnat.com> + + * 5vml-tgt.adb: Use Gas instead of VMS Macro to build auto init shared + libraries. + 2004-04-06 Pascal Obry <obry@gnat.com> * 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 + <<Continue>> 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); |