From b442d55aaee2601e0a59b314fafbab2cffe7738b Mon Sep 17 00:00:00 2001 From: charlet Date: Wed, 21 May 2014 13:19:28 +0000 Subject: [PATCH] 2014-05-21 Robert Dewar * sem_warn.adb: Minor fix to warning messages (use ?? instead of ?). 2014-05-21 Vincent Celier * gnatcmd.adb (GNATCmd): For platforms other than VMS, recognize switch --version and --help. 2014-05-21 Robert Dewar * sem_elab.adb (Is_Call_Of_Generic_Formal): New function. 2014-05-21 Ed Schonberg * sem_ch5.adb (Analyze_Iterator_Specification): Set type of iterator variable when the domain of iteration is a formal container and this is an element iterator. 2014-05-21 Bob Duff * sem_ch12.adb: Minor reformatting. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@210707 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 24 +++++++ gcc/ada/gnatcmd.adb | 194 +++++++++++++++++++++++++++------------------------ gcc/ada/sem_ch12.adb | 1 + gcc/ada/sem_ch5.adb | 15 +++- gcc/ada/sem_elab.adb | 45 ++++++++---- gcc/ada/sem_warn.adb | 4 +- 6 files changed, 172 insertions(+), 111 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6b1eaae..26df7be 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,29 @@ 2014-05-21 Robert Dewar + * sem_warn.adb: Minor fix to warning messages (use ?? instead + of ?). + +2014-05-21 Vincent Celier + + * gnatcmd.adb (GNATCmd): For platforms other than VMS, recognize + switch --version and --help. + +2014-05-21 Robert Dewar + + * sem_elab.adb (Is_Call_Of_Generic_Formal): New function. + +2014-05-21 Ed Schonberg + + * sem_ch5.adb (Analyze_Iterator_Specification): Set type of + iterator variable when the domain of iteration is a formal + container and this is an element iterator. + +2014-05-21 Bob Duff + + * sem_ch12.adb: Minor reformatting. + +2014-05-21 Robert Dewar + * sinfo.ads, sem_ch12.adb, sem_warn.adb: Minor reformatting. 2014-05-21 Robert Dewar diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 494fd4d..b2a865c 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2014, 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- -- @@ -45,6 +45,7 @@ with Sdefault; with Sinput.P; with Snames; use Snames; with Stringt; +with Switch; use Switch; with Table; with Targparm; with Tempdir; @@ -1382,6 +1383,9 @@ procedure GNATCmd is end if; end Set_Library_For; + procedure Check_Version_And_Help is + new Check_Version_And_Help_G (Non_VMS_Usage); + -- Start of processing for GNATCmd begin @@ -1488,122 +1492,128 @@ begin -- If not on VMS, scan the command line directly else - if Argument_Count = 0 then - Non_VMS_Usage; - return; - else - begin - loop - if Argument_Count > Command_Arg - and then Argument (Command_Arg) = "-v" - then - Verbose_Mode := True; - Command_Arg := Command_Arg + 1; + -- First, scan to detect --version and/or --help - elsif Argument_Count > Command_Arg - and then Argument (Command_Arg) = "-dn" - then - Keep_Temporary_Files := True; - Command_Arg := Command_Arg + 1; + Check_Version_And_Help ("GNAT", "1996"); - else - exit; - end if; - end loop; + begin + loop + if Command_Arg <= Argument_Count + and then Argument (Command_Arg) = "-v" + then + Verbose_Mode := True; + Command_Arg := Command_Arg + 1; - The_Command := Real_Command_Type'Value (Argument (Command_Arg)); + elsif Command_Arg <= Argument_Count + and then Argument (Command_Arg) = "-dn" + then + Keep_Temporary_Files := True; + Command_Arg := Command_Arg + 1; - if Command_List (The_Command).VMS_Only then - Non_VMS_Usage; - Fail - ("Command """ - & Command_List (The_Command).Cname.all - & """ can only be used on VMS"); + else + exit; end if; + end loop; - exception - when Constraint_Error => + -- If there is no command, just output the usage - -- Check if it is an alternate command + if Command_Arg > Argument_Count then + Non_VMS_Usage; + return; + end if; - declare - Alternate : Alternate_Command; + The_Command := Real_Command_Type'Value (Argument (Command_Arg)); - begin - Alternate := Alternate_Command'Value - (Argument (Command_Arg)); - The_Command := Corresponding_To (Alternate); - - exception - when Constraint_Error => - Non_VMS_Usage; - Fail ("Unknown command: " & Argument (Command_Arg)); - end; - end; + if Command_List (The_Command).VMS_Only then + Non_VMS_Usage; + Fail + ("Command """ + & Command_List (The_Command).Cname.all + & """ can only be used on VMS"); + end if; + + exception + when Constraint_Error => - -- Get the arguments from the command line and from the eventual - -- argument file(s) specified on the command line. + -- Check if it is an alternate command - for Arg in Command_Arg + 1 .. Argument_Count loop declare - The_Arg : constant String := Argument (Arg); + Alternate : Alternate_Command; begin - -- Check if an argument file is specified + Alternate := Alternate_Command'Value + (Argument (Command_Arg)); + The_Command := Corresponding_To (Alternate); + + exception + when Constraint_Error => + Non_VMS_Usage; + Fail ("Unknown command: " & Argument (Command_Arg)); + end; + end; - if The_Arg (The_Arg'First) = '@' then - declare - Arg_File : Ada.Text_IO.File_Type; - Line : String (1 .. 256); - Last : Natural; + -- Get the arguments from the command line and from the eventual + -- argument file(s) specified on the command line. - begin - -- Open the file and fail if the file cannot be found + for Arg in Command_Arg + 1 .. Argument_Count loop + declare + The_Arg : constant String := Argument (Arg); - begin - Open - (Arg_File, In_File, - The_Arg (The_Arg'First + 1 .. The_Arg'Last)); + begin + -- Check if an argument file is specified - exception - when others => - Put - (Standard_Error, "Cannot open argument file """); - Put - (Standard_Error, - The_Arg (The_Arg'First + 1 .. The_Arg'Last)); + if The_Arg (The_Arg'First) = '@' then + declare + Arg_File : Ada.Text_IO.File_Type; + Line : String (1 .. 256); + Last : Natural; - Put_Line (Standard_Error, """"); - raise Error_Exit; - end; + begin + -- Open the file and fail if the file cannot be found - -- Read line by line and put the content of each non- - -- empty line in the Last_Switches table. + begin + Open + (Arg_File, In_File, + The_Arg (The_Arg'First + 1 .. The_Arg'Last)); + + exception + when others => + Put + (Standard_Error, "Cannot open argument file """); + Put + (Standard_Error, + The_Arg (The_Arg'First + 1 .. The_Arg'Last)); - while not End_Of_File (Arg_File) loop - Get_Line (Arg_File, Line, Last); + Put_Line (Standard_Error, """"); + raise Error_Exit; + end; - if Last /= 0 then - Last_Switches.Increment_Last; - Last_Switches.Table (Last_Switches.Last) := - new String'(Line (1 .. Last)); - end if; - end loop; + -- Read line by line and put the content of each non- + -- empty line in the Last_Switches table. - Close (Arg_File); - end; + while not End_Of_File (Arg_File) loop + Get_Line (Arg_File, Line, Last); - else - -- It is not an argument file; just put the argument in - -- the Last_Switches table. + if Last /= 0 then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(Line (1 .. Last)); + end if; + end loop; - Last_Switches.Increment_Last; - Last_Switches.Table (Last_Switches.Last) := - new String'(The_Arg); - end if; - end; - end loop; - end if; + Close (Arg_File); + end; + + else + -- It is not an argument file; just put the argument in + -- the Last_Switches table. + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(The_Arg); + end if; + end; + end loop; end if; declare diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 2d74876..5494ab5 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -10070,6 +10070,7 @@ package body Sem_Ch12 is Set_Corresponding_Spec (Act_Body, Act_Decl_Id); Check_Generic_Actuals (Act_Decl_Id, False); + Check_Initialized_Types; -- Install primitives hidden at the point of the instantiation but diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 41f310d..5f14622 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1868,9 +1868,18 @@ package body Sem_Ch5 is if Of_Present (N) then if Has_Aspect (Typ, Aspect_Iterable) then - if No (Get_Iterable_Type_Primitive (Typ, Name_Element)) then - Error_Msg_N ("missing Element primitive for iteration", N); - end if; + declare + Elt : constant Entity_Id := + Get_Iterable_Type_Primitive (Typ, Name_Element); + begin + if No (Elt) then + Error_Msg_N + ("missing Element primitive for iteration", N); + + else + Set_Etype (Def_Id, Etype (Elt)); + end if; + end; -- For a predefined container, The type of the loop variable is -- the Iterator_Element aspect of the container type. diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index fa39312..02762ff 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -541,6 +541,27 @@ package body Sem_Elab is -- warnings on the scope are also suppressed. For the internal case, -- we ignore this flag. + function Is_Call_Of_Generic_Formal return Boolean; + -- Returns True if node N is a call to a generic formal subprogram + + ------------------------------- + -- Is_Call_Of_Generic_Formal -- + ------------------------------- + + function Is_Call_Of_Generic_Formal return Boolean is + begin + return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) + + -- For now, we detect this by looking for the strange identifier + -- node, whose Chars reflect the name of the generic formal, but + -- the Chars of the Entity references the generic actual. + + and then Nkind (Name (N)) = N_Identifier + and then Chars (Name (N)) /= Chars (Entity (Name (N))); + end Is_Call_Of_Generic_Formal; + + -- Start of processing for Check_A_Call + begin -- If the call is known to be within a local Suppress Elaboration -- pragma, nothing to check. This can happen in task bodies. @@ -752,8 +773,9 @@ package body Sem_Elab is -- However, if we are doing dynamic elaboration, we need to chase the -- call in the usual manner. - -- We do not handle the case of calling a generic formal correctly in - -- the static case.??? + -- We also need to chase the call in the usual manner if it is a call + -- to a generic formal parameter, since that case was not handled as + -- part of the processing of the template. Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); @@ -773,14 +795,8 @@ package body Sem_Elab is if Unit_Caller /= No_Unit and then Unit_Callee /= Unit_Caller and then not Dynamic_Elaboration_Checks - - -- This is an attempt to solve the problem of mishandling of - -- generic formal parameters, but it does not work right yet ??? - - -- and then not Used_As_Generic_Actual (Ent) + and then not Is_Call_Of_Generic_Formal then - -- It is here that things go wrong for calling a generic formal??? - E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); -- If we don't get a spec entity, just ignore call. Not quite @@ -796,11 +812,12 @@ package body Sem_Elab is E_Scope := Scope (E_Scope); end loop; - -- For the case N is not an instance, or a call within instance, we - -- recompute E_Scope for the error message, since we do NOT want to - -- go to the unit which has the ultimate declaration in the case of - -- renaming and derivation and we also want to go to the generic unit - -- in the case of an instance, and no further. + -- For the case where N is not an instance, and is not a call within + -- instance to other than a generic formal, we recompute E_Scope + -- for the error message, since we do NOT want to go to the unit + -- which has the ultimate declaration in the case of renaming and + -- derivation and we also want to go to the generic unit in the + -- case of an instance, and no further. else -- Loop to carefully follow renamings and derivations one step diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 26202b0..6571a9e 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -852,9 +852,9 @@ package body Sem_Warn is end if; if Res then - Error_Msg_N ("?!variable& of a generic type is potentially " + Error_Msg_N ("??!variable& of a generic type is potentially " & "uninitialized", Ent); - Error_Msg_NE ("\?instantiations must provide fully initialized " + Error_Msg_NE ("\??instantiations must provide fully initialized " & "type for&", Ent, T); end if; -- 2.7.4