+2015-02-20 Robert Dewar <dewar@adacore.com>
+
+ * a-dispat.adb, a-stcoed.ads: Minor reformatting.
+
+2015-02-20 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch13.adb (Build_Discrete_Static_Predicate): Allow static
+ predicate for non-static subtype.
+ (Build_Predicate_Functions): Do not assume subtype associated with a
+ static predicate must be static.
+
+2015-02-20 Robert Dewar <dewar@adacore.com>
+
+ * errout.adb (Set_Msg_Node): Better handling of internal names
+ (Set_Msg_Node): Kill message when we cannot eliminate internal name.
+ * errout.ads: Document additional case of message deletion.
+ * namet.adb (Is_Internal_Name): Refined to consider wide
+ strings in brackets notation and character literals not to be
+ internal names.
+ * sem_ch8.adb (Find_Selected_Component): Give additional error
+ when selector name is a subprogram whose first parameter has
+ the same type as the prefix, but that type is untagged.
+
2015-02-20 Robert Dewar <dewar@adacore.com>
* g-allein.ads, g-alveop.adb, g-alveop.ads, opt.ads: Minor reformatting
procedure Yield is
Self_Id : constant System.Tasking.Task_Id :=
- System.Task_Primitives.Operations.Self;
+ System.Task_Primitives.Operations.Self;
begin
-- If pragma Detect_Blocking is active, Program_Error must be
procedure Suspend_Until_True_And_Set_Deadline
(S : in out Suspension_Object;
- TS : Ada.Real_Time.Time_Span);
+ TS : Ada.Real_Time.Time_Span);
end Ada.Synchronous_Task_Control.EDF;
Nam := Pragma_Name (Node);
Loc := Sloc (Node);
- -- The other cases have Chars fields, and we want to test for possible
- -- internal names, which generally represent something gone wrong. An
- -- exception is the case of internal type names, where we try to find a
- -- reasonable external representation for the external name
+ -- The other cases have Chars fields
+
+ -- First deal with internal names, which generally represent something
+ -- gone wrong. First attempt: if this is a rewritten node that rewrites
+ -- something with a Chars field that is not an internal name, use that.
+
+ elsif Is_Internal_Name (Chars (Node))
+ and then Nkind (Original_Node (Node)) in N_Has_Chars
+ and then not Is_Internal_Name (Chars (Original_Node (Node)))
+ then
+ Nam := Chars (Original_Node (Node));
+ Loc := Sloc (Original_Node (Node));
+
+ -- Another shot for internal names, in the case of internal type names,
+ -- we try to find a reasonable representation for the external name.
elsif Is_Internal_Name (Chars (Node))
and then
((Is_Entity_Name (Node)
- and then Present (Entity (Node))
- and then Is_Type (Entity (Node)))
- or else
- (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node)))
+ and then Present (Entity (Node))
+ and then Is_Type (Entity (Node)))
+ or else
+ (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node)))
then
if Nkind (Node) = N_Identifier then
Ent := Entity (Node);
Nam := Chars (Ent);
end if;
- -- If not internal name, just use name in Chars field
+ -- If not internal name, or if we could not find a reasonable possible
+ -- substitution for the internal name, just use name in Chars field.
else
Nam := Chars (Node);
Kill_Message := True;
end if;
+ -- If we still have an internal name, kill the message (will only
+ -- work if we already had errors!)
+
+ if Is_Internal_Name then
+ Kill_Message := True;
+ end if;
-- Remaining step is to adjust casing and possibly add 'Class
Adjust_Name_Case (Loc);
-- messages. Warning messages are only suppressed for case 1, and
-- when they come from other than the main extended unit.
+ -- 7. If an error or warning references an internal name, and we have
+ -- already placed an error (not warning) message at that location,
+ -- then we assume this is cascaded junk and delete the message.
+
+ -- This normal suppression action may be overridden in cases 2-5 (but not
+ -- in case 1 or 7 by setting All_Errors mode, or by setting the special
+ -- unconditional message insertion character (!) as described below.
-- This normal suppression action may be overridden in cases 2-5 (but
-- not in case 1) by setting All_Errors mode, or by setting the special
-- unconditional message insertion character (!) as described below.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
function Is_Internal_Name (Id : Name_Id) return Boolean is
begin
- Get_Name_String (Id);
- return Is_Internal_Name;
+ if Id in Error_Name_Or_No_Name then
+ return False;
+ else
+ Get_Name_String (Id);
+ return Is_Internal_Name;
+ end if;
end Is_Internal_Name;
----------------------
-- Version taking its input from Name_Buffer
function Is_Internal_Name return Boolean is
+ J : Natural;
+
begin
+ -- AAny name starting with underscore is internal
+
if Name_Buffer (1) = '_'
or else Name_Buffer (Name_Len) = '_'
then
return True;
+ -- Allow quoted character
+
+ elsif Name_Buffer (1) = ''' then
+ return False;
+
+ -- All other cases, scan name
+
else
-- Test backwards, because we only want to test the last entity
-- name if the name we have is qualified with other entities.
- for J in reverse 1 .. Name_Len loop
- if Is_OK_Internal_Letter (Name_Buffer (J)) then
+ J := Name_Len;
+ while J /= 0 loop
+
+ -- Skip stuff between brackets (A-F OK there)
+
+ if Name_Buffer (J) = ']' then
+ loop
+ J := J - 1;
+ exit when J = 1 or else Name_Buffer (J) = '[';
+ end loop;
+
+ -- Test for internal letter
+
+ elsif Is_OK_Internal_Letter (Name_Buffer (J)) then
return True;
-- Quit if we come to terminating double underscore (note that
then
return False;
end if;
+
+ J := J - 1;
end loop;
end if;
BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp));
-- Low bound and high bound value of base type of Typ
- TLo : constant Uint := Expr_Value (Type_Low_Bound (Typ));
- THi : constant Uint := Expr_Value (Type_High_Bound (Typ));
- -- Low bound and high bound values of static subtype Typ
+ TLo : Uint;
+ THi : Uint;
+ -- Bounds for constructing the static predicate. We use the bound of the
+ -- subtype if it is static, otherwise the corresponding base type bound.
+ -- Note: a non-static subtype can have a static predicate.
type REnt is record
Lo, Hi : Uint;
-- Start of processing for Build_Discrete_Static_Predicate
begin
+ -- Establish bounds for the predicate
+
+ if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
+ TLo := Expr_Value (Type_Low_Bound (Typ));
+ else
+ TLo := BLo;
+ end if;
+
+ if Compile_Time_Known_Value (Type_High_Bound (Typ)) then
+ THi := Expr_Value (Type_High_Bound (Typ));
+ else
+ THi := BHi;
+ end if;
+
-- Analyze the expression to see if it is a static predicate
declare
-- For discrete subtype, build the static predicate list
if Is_Discrete_Type (Typ) then
- if not Is_Static_Subtype (Typ) then
-
- -- This can only happen in the presence of previous
- -- semantic errors.
-
- pragma Assert (Serious_Errors_Detected > 0);
- return;
- end if;
-
Build_Discrete_Static_Predicate (Typ, Expr, Object_Name);
-- If we don't get a static predicate list, it means that we
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
Premature_Usage (P);
elsif Nkind (P) /= N_Attribute_Reference then
- Error_Msg_N (
- "invalid prefix in selected component&", P);
+
+ -- This may have been meant as a prefixed call to a primitive
+ -- of an untagged type.
+
+ declare
+ F : constant Entity_Id :=
+ Current_Entity (Selector_Name (N));
+ begin
+ if Present (F)
+ and then Is_Overloadable (F)
+ and then Present (First_Entity (F))
+ and then Etype (First_Entity (F)) = Etype (P)
+ and then not Is_Tagged_Type (Etype (P))
+ then
+ Error_Msg_N
+ ("prefixed call is only allowed for objects "
+ & "of a tagged type", N);
+ end if;
+ end;
+
+ Error_Msg_N ("invalid prefix in selected component&", P);
if Is_Access_Type (P_Type)
and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type
then
Error_Msg_N
- ("\dereference must not be of an incomplete type " &
- "(RM 3.10.1)", P);
+ ("\dereference must not be of an incomplete type "
+ & "(RM 3.10.1)", P);
end if;
else
- Error_Msg_N (
- "invalid prefix in selected component", P);
+ Error_Msg_N ("invalid prefix in selected component", P);
end if;
end if;
projects / gcc.git / commitdiff