2010-10-07 Robert Dewar <dewar@adacore.com>
+ * 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 <rybin@adacore.com>
+
+ * gnat_ugn.texi: Add missing word.
+
+2010-10-07 Robert Dewar <dewar@adacore.com>
+
* exp_util.adb (Insert_Actions): Add handling of
N_Parametrized_Expression.
* par-ch6.adb (P_Subprogram): Add parsing of parametrized expression
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;
-- 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
@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
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;
-- 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
-- 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;
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
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
Pop_Scope_Stack;
return Decl_Node;
-
end P_Subprogram;
---------------------------------
-- --
-- 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- --
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;
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;
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.
-- 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
then
T2 := T1;
- else
- -- Previous error in declaration
+ -- Previous error in declaration
+ else
return;
end if;
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
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;
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.
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));
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);
-- 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
OSDN Git Service
