From 26e182d2e080cfccf7a2a11e9f675fb4c757948c Mon Sep 17 00:00:00 2001 From: charlet Date: Thu, 7 Oct 2010 12:37:10 +0000 Subject: [PATCH] 2010-10-07 Robert Dewar * par-ch6.adb: Fix error in handling of parametrized expressions. * par-ch4.adb (P_Name): Allow qualified expression as name in Ada 2012 mode. (P_Simple_Expression): Better message for qualified expression prefix * s-crc32.adb: Minor reformatting. * exp_intr.adb (Expand_Unc_Deallocation): Remove test for empty storage pool (this test is moved to Sem_Intr). * sem_intr.adb (Check_Intrinsic_Call): Add check for deallocation from empty storage pool, moved here from Exp_Intr and made into error. (Check_Intrinsic_Call): Remove assumption in generating not-null free warning that the name of the instantiation is Free. * sinput.adb (Tree_Read): Document use of illegal free call allowed in GNAT mode. * types.ads: Remove storage size clauses from big types (since we may need to do deallocations, which are now illegal for empty pools). 2010-10-07 Sergey Rybin * gnat_ugn.texi: Add missing word. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165099 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 22 ++++++++++++++++++++ gcc/ada/exp_intr.adb | 6 +----- gcc/ada/gnat_ugn.texi | 2 +- gcc/ada/par-ch4.adb | 43 ++++++++++++++++++++++++++++++--------- gcc/ada/par-ch6.adb | 33 +++++++++++++++++++----------- gcc/ada/s-crc32.adb | 3 +-- gcc/ada/sem_intr.adb | 56 ++++++++++++++++++++++++++++++++++++++++----------- gcc/ada/sinput.adb | 5 +---- gcc/ada/types.ads | 10 +++++---- 9 files changed, 131 insertions(+), 49 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4ed46f1..300a861 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,27 @@ 2010-10-07 Robert Dewar + * par-ch6.adb: Fix error in handling of parametrized expressions. + * par-ch4.adb (P_Name): Allow qualified expression as name in Ada 2012 + mode. + (P_Simple_Expression): Better message for qualified expression prefix + * s-crc32.adb: Minor reformatting. + * exp_intr.adb (Expand_Unc_Deallocation): Remove test for empty + storage pool (this test is moved to Sem_Intr). + * sem_intr.adb (Check_Intrinsic_Call): Add check for deallocation from + empty storage pool, moved here from Exp_Intr and made into error. + (Check_Intrinsic_Call): Remove assumption in generating not-null free + warning that the name of the instantiation is Free. + * sinput.adb (Tree_Read): Document use of illegal free call allowed in + GNAT mode. + * types.ads: Remove storage size clauses from big types (since we may + need to do deallocations, which are now illegal for empty pools). + +2010-10-07 Sergey Rybin + + * gnat_ugn.texi: Add missing word. + +2010-10-07 Robert Dewar + * exp_util.adb (Insert_Actions): Add handling of N_Parametrized_Expression. * par-ch6.adb (P_Subprogram): Add parsing of parametrized expression diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index ecf1026..89920eb 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -851,7 +851,7 @@ package body Exp_Intr is Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); - Desig_T : constant Entity_Id := Designated_Type (Typ); + Desig_T : constant Entity_Id := Designated_Type (Typ); Gen_Code : Node_Id; Free_Node : Node_Id; Deref : Node_Id; @@ -866,10 +866,6 @@ package body Exp_Intr is -- them to the tree, and that can disturb current value settings. begin - if No_Pool_Assigned (Rtyp) then - Error_Msg_N ("?deallocation from empty storage pool!", N); - end if; - -- Nothing to do if we know the argument is null if Known_Null (N) then diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index ae154fc..f04971c 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -17324,7 +17324,7 @@ sources and applied rules (coding standard); @item list of exempted coding standard violations; @item list of non-exempted coding standard violations; @item list of problems in the definition of exemption sections; -@item of language violations (compile-time errors) detected in processed sources; +@item list of language violations (compile-time errors) detected in processed sources; @end itemize @node General gnatcheck Switches diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index a7952c5..10ea58f 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -233,13 +233,18 @@ package body Ch4 is Save_Scan_State (Scan_State); -- at apostrophe Scan; -- past apostrophe - -- If left paren, then this might be a qualified expression, but we - -- are only in the business of scanning out names, so return with - -- Token backed up to point to the apostrophe. The treatment for - -- the range attribute is similar (we do not consider x'range to - -- be a name in this grammar). + -- Qualified expression in Ada 2012 mode (treated as a name) - if Token = Tok_Left_Paren or else Token = Tok_Range then + if Ada_Version >= Ada_12 and then Token = Tok_Left_Paren then + goto Scan_Name_Extension_Apostrophe; + + -- If left paren not in Ada 2012, then it is not part of the name, + -- since qualified expressions are not names in prior versions of + -- Ada, so return with Token backed up to point to the apostrophe. + -- The treatment for the range attribute is similar (we do not + -- consider x'range to be a name in this grammar). + + elsif Token = Tok_Left_Paren or else Token = Tok_Range then Restore_Scan_State (Scan_State); -- to apostrophe Expr_Form := EF_Simple_Name; return Name_Node; @@ -363,6 +368,10 @@ package body Ch4 is -- the current token to Tok_Semicolon, and returns True. -- Otherwise returns False. + ------------------------------------ + -- Apostrophe_Should_Be_Semicolon -- + ------------------------------------ + function Apostrophe_Should_Be_Semicolon return Boolean is begin if Token_Is_At_Start_Of_Line then @@ -378,14 +387,20 @@ package body Ch4 is -- Start of processing for Scan_Apostrophe begin + -- Check for qualified expression case in Ada 2012 mode + + if Ada_Version >= Ada_12 and then Token = Tok_Left_Paren then + Name_Node := P_Qualified_Expression (Name_Node); + goto Scan_Name_Extension; + -- If range attribute after apostrophe, then return with Token -- pointing to the apostrophe. Note that in this case the prefix -- need not be a simple name (cases like A.all'range). Similarly -- if there is a left paren after the apostrophe, then we also -- return with Token pointing to the apostrophe (this is the - -- qualified expression case). + -- aggregate case, or some error case). - if Token = Tok_Range or else Token = Tok_Left_Paren then + elsif Token = Tok_Range or else Token = Tok_Left_Paren then Restore_Scan_State (Scan_State); -- to apostrophe Expr_Form := EF_Name; return Name_Node; @@ -2054,7 +2069,17 @@ package body Ch4 is if Token = Tok_Dot then Error_Msg_SC ("prefix for selection is not a name"); - raise Error_Resync; + + -- If qualified expression, comment and continue, otherwise something + -- is pretty nasty so do an Error_Resync call. + + if Ada_Version < Ada_12 + and then Nkind (Node1) = N_Qualified_Expression + then + Error_Msg_SC ("\would be legal in Ada 2012 mode"); + else + raise Error_Resync; + end if; end if; -- Special test to improve error recovery: If the current token is diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 2c979cf..994e166 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -632,26 +632,36 @@ package body Ch6 is return False; -- If currently pointing to BEGIN or a declaration keyword - -- or a pragma then we definitely do not have a parametrized - -- expression. + -- or a pragma, then we definitely have a subprogram body. + -- This is a common case, so worth testing first. - elsif Token in Token_Class_Declk - or else Token = Tok_Begin + elsif Token = Tok_Begin + or else Token in Token_Class_Declk or else Token = Tok_Pragma then return False; - -- A common error case, missing BEGIN before RETURN + -- Test for tokens which could only start an expression and + -- thus signal the case of a parametrized expression. - elsif Token = Tok_Return then - return False; + elsif Token in Token_Class_Literal + or else Token in Token_Class_Unary_Addop + or else Token = Tok_Left_Paren + or else Token = Tok_Abs + or else Token = Tok_Null + or else Token = Tok_New + or else Token = Tok_Not + then + return True; - -- Anything other than an identifier must be a parametrized - -- expression at this stage. Probably we could do a little - -- better job of distingushing some more error cases. + -- Anything other than an identifier must be a body at + -- this stage. Probably we could do a little better job of + -- distingushing some more error cases, but it seems right + -- to err on the side of favoring a body over the + -- new-fangled parametrized expression. elsif Token /= Tok_Identifier then - return True; + return False; -- For identifier we have to scan ahead if identifier is -- followed by a colon or a comma, it is a declaration and @@ -740,7 +750,6 @@ package body Ch6 is Pop_Scope_Stack; return Decl_Node; - end P_Subprogram; --------------------------------- diff --git a/gcc/ada/s-crc32.adb b/gcc/ada/s-crc32.adb index 1687adc..b133780 100644 --- a/gcc/ada/s-crc32.adb +++ b/gcc/ada/s-crc32.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -130,7 +130,6 @@ package body System.CRC32 is procedure Update (C : in out CRC32; Value : Character) is V : constant CRC32 := CRC32 (Character'Pos (Value)); - begin C := Shift_Right (C, 8) xor Table (V xor (C and 16#0000_00FF#)); end Update; diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index 20a1614..f1d8605 100644 --- a/gcc/ada/sem_intr.adb +++ b/gcc/ada/sem_intr.adb @@ -31,6 +31,7 @@ with Errout; use Errout; with Fname; use Fname; with Lib; use Lib; with Namet; use Namet; +with Sem_Aux; use Sem_Aux; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -96,10 +97,32 @@ package body Sem_Intr is procedure Check_Intrinsic_Call (N : Node_Id) is Nam : constant Entity_Id := Entity (Name (N)); - Cnam : constant Name_Id := Chars (Nam); Arg1 : constant Node_Id := First_Actual (N); + Typ : Entity_Id; + Rtyp : Entity_Id; + Cnam : Name_Id; + Unam : Node_Id; begin + -- Set argument type if argument present + + if Present (Arg1) then + Typ := Etype (Arg1); + Rtyp := Underlying_Type (Root_Type (Typ)); + end if; + + -- Set intrinsic name (getting original name in the generic case) + + Unam := Ultimate_Alias (Nam); + + if Present (Parent (Unam)) + and then Present (Generic_Parent (Parent (Unam))) + then + Cnam := Chars (Generic_Parent (Parent (Unam))); + else + Cnam := Chars (Nam); + end if; + -- For Import_xxx calls, argument must be static string. A string -- literal is legal even in Ada83 mode, where such literals are -- not static. @@ -136,12 +159,23 @@ package body Sem_Intr is -- Check for the case of freeing a non-null object which will raise -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr. - elsif Cnam = Name_Free + elsif Cnam = Name_Unchecked_Deallocation and then Can_Never_Be_Null (Etype (Arg1)) then Error_Msg_N ("freeing `NOT NULL` object will raise Constraint_Error?", N); + -- For unchecked deallocation, error to deallocate from empty pool. + -- Note: this test used to be in Exp_Intr as a warning, but AI 157 + -- issues a binding intepretation that this should be an error, and + -- consequently it needs to be done in the semantic analysis so that + -- the error is issued even in semantics only mode. + + elsif Cnam = Name_Unchecked_Deallocation + and then No_Pool_Assigned (Rtyp) + then + Error_Msg_N ("deallocation from empty storage pool!", N); + -- For now, no other special checks are required else @@ -188,9 +222,9 @@ package body Sem_Intr is then T2 := T1; - else - -- Previous error in declaration + -- Previous error in declaration + else return; end if; @@ -198,19 +232,19 @@ package body Sem_Intr is T2 := Etype (Next_Formal (First_Formal (E))); end if; + -- Same types, predefined operator will apply + if Root_Type (T1) = Root_Type (T2) or else Root_Type (T1) = Root_Type (Ret) then - -- Same types, predefined operator will apply - null; + -- Expansion will introduce conversions if sizes are not equal + elsif Is_Integer_Type (Underlying_Type (T1)) and then Is_Integer_Type (Underlying_Type (T2)) and then Is_Integer_Type (Underlying_Type (Ret)) then - -- Expansion will introduce conversions if sizes are not equal - null; else @@ -234,12 +268,10 @@ package body Sem_Intr is then T1 := Etype (First_Formal (E)); - if No (Next_Formal (First_Formal (E))) then - - -- Previous error in declaration + -- Return if previous error in declaration, otherwise get T2 type + if No (Next_Formal (First_Formal (E))) then return; - else T2 := Etype (Next_Formal (First_Formal (E))); end if; diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index c2af505..10f188c 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -792,8 +792,7 @@ package body Sinput is else -- Free the buffer, we use Free here, because we used malloc -- or realloc directly to allocate the tables. That is - -- because we were playing the big array trick. We need to - -- suppress the warning for freeing from an empty pool! + -- because we were playing the big array trick. -- We have to recreate a proper pointer to the actual array -- from the zero origin pointer stored in the source table. @@ -801,9 +800,7 @@ package body Sinput is Tmp1 := To_Source_Buffer_Ptr (S.Source_Text (S.Source_First)'Address); - pragma Warnings (Off); Free_Ptr (Tmp1); - pragma Warnings (On); if S.Lines_Table /= null then Memory.Free (To_Address (S.Lines_Table)); diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 1568290..5fcba82 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -122,8 +122,9 @@ package Types is subtype Big_String is String (Positive); type Big_String_Ptr is access all Big_String; - for Big_String_Ptr'Storage_Size use 0; - -- Virtual type for handling imported big strings + -- Virtual type for handling imported big strings. Note that we should + -- never have any allocators for this type, but we don't give a storage + -- size of zero, since there are legitimate deallocations going on. function To_Big_String_Ptr is new Unchecked_Conversion (System.Address, Big_String_Ptr); @@ -197,13 +198,14 @@ package Types is -- Source_Buffer_Ptr, see Osint.Read_Source_File for details. type Source_Buffer_Ptr is access all Big_Source_Buffer; - for Source_Buffer_Ptr'Storage_Size use 0; -- Pointer to source buffer. We use virtual origin addressing for source -- buffers, with thin pointers. The pointer points to a virtual instance -- of type Big_Source_Buffer, where the actual type is in fact of type -- Source_Buffer. The address is adjusted so that the virtual origin -- addressing works correctly. See Osint.Read_Source_Buffer for further - -- details. + -- details. Again, as for Big_String_Ptr, we should never allocate using + -- this type, but we don't give a storage size clause of zero, since we + -- may end up doing deallocations of instances allocated manually. subtype Source_Ptr is Text_Ptr; -- Type used to represent a source location, which is a subscript of a -- 2.7.4