2010-10-12 Robert Dewar <dewar@adacore.com>
+ * par-endh.adb (Check_End): Don't swallow semicolon or aspects after
+ END RECORD.
+ * sem_attr.adb (Eval_Attribute): Code clean up.
+
+2010-10-12 Robert Dewar <dewar@adacore.com>
+
+ * par-ch12.adb (P_Formal_Private_Type_Definition): Improve error
+ messages and recovery for case of out of order Abstract/Tagged/Private
+ keywords.
+ * par-ch3.adb (P_Type_Declaration): Improve error messages and recovery
+ for case of out of order Abstract/Tagged/Private keywords.
+
+2010-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * inline.adb (Analyze_Inlined_Bodies): Restrict previous change to case
+ where child unit is main unit of compilation.
+
+2010-10-12 Robert Dewar <dewar@adacore.com>
+
* aspects.ads, aspects.adb (Move_Aspects): New procedure.
* atree.ads, atree.adb: (New_Copy): Does not copy aspect specifications
* sinfo.ads, par-ch3.adb, par-ch6.adb, par-ch7.adb, par-ch9.adb,
Pack : Entity_Id;
S : Succ_Index;
- function Is_Ancestor
+ function Is_Ancestor_Of_Main
(U_Name : Entity_Id;
Nam : Node_Id) return Boolean;
-- Determine whether the unit whose body is loaded is an ancestor of
- -- a unit mentioned in a with_clause of that body. The body is not
+ -- the main unit, and has a with_clause on it. The body is not
-- analyzed yet, so the check is purely lexical: the name of the with
-- clause is a selected component, and names of ancestors must match.
- -----------------
- -- Is_Ancestor --
- -----------------
+ -------------------------
+ -- Is_Ancestor_Of_Main --
+ -------------------------
- function Is_Ancestor
+ function Is_Ancestor_Of_Main
(U_Name : Entity_Id;
Nam : Node_Id) return Boolean
is
return False;
else
+ if Chars (Selector_Name (Nam)) /=
+ Chars (Cunit_Entity (Main_Unit))
+ then
+ return False;
+ end if;
+
Pref := Prefix (Nam);
if Nkind (Pref) = N_Identifier then
else
-- A is an ancestor of A.B.C if it is an ancestor of A.B
- return Is_Ancestor (U_Name, Pref);
+ return Is_Ancestor_Of_Main (U_Name, Pref);
end if;
end if;
- end Is_Ancestor;
+ end Is_Ancestor_Of_Main;
-- Start of processing for Analyze_Inlined_Bodies
Item := First (Context_Items (Body_Unit));
while Present (Item) loop
if Nkind (Item) = N_With_Clause
- and then Is_Ancestor (U_Id, Name (Item))
+ and then
+ Is_Ancestor_Of_Main (U_Id, Name (Item))
then
Set_Is_Inlined (U_Id, False);
exit;
Set_Sloc (Def_Node, Token_Ptr);
T_Private;
+
+ if Token = Tok_Tagged then -- CODEFIX
+ Error_Msg_SC ("TAGGED must come before PRIVATE");
+ Scan; -- past TAGGED
+
+ elsif Token = Tok_Abstract then -- CODEFIX
+ Error_Msg_SC ("`ABSTRACT TAGGED` must come before PRIVATE");
+ Scan; -- past ABSTRACT
+
+ if Token = Tok_Tagged then
+ Scan; -- past TAGGED
+ end if;
+ end if;
+
return Def_Node;
end P_Formal_Private_Type_Definition;
-- Error recovery: can raise Error_Resync
- -- Note: The processing for full type declaration, incomplete type
- -- declaration, private type declaration and type definition is
- -- included in this function. The processing for concurrent type
- -- declarations is NOT here, but rather in chapter 9 (i.e. this
- -- function handles only declarations starting with TYPE).
+ -- The processing for full type declarations, incomplete type declarations,
+ -- private type declarations and type definitions is included in this
+ -- function. The processing for concurrent type declarations is NOT here,
+ -- but rather in chapter 9 (this function handles only declarations
+ -- starting with TYPE).
function P_Type_Declaration return Node_Id is
Abstract_Present : Boolean := False;
when Tok_Private =>
Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
Scan; -- past PRIVATE
+
+ -- Check error cases of private [abstract] tagged
+
+ if Token = Tok_Abstract then
+ Error_Msg_SC ("`ABSTRACT TAGGED` must come before PRIVATE");
+ Scan; -- past ABSTRACT
+
+ if Token = Tok_Tagged then
+ Scan; -- past TAGGED
+ end if;
+
+ elsif Token = Tok_Tagged then
+ Error_Msg_SC ("TAGGED must come before PRIVATE");
+ Scan; -- past TAGGED
+ end if;
+
exit;
-- Ada 2005 (AI-345): Protected, synchronized or task interface
end if;
end if;
- -- Scan aspect specifications if permitted here
+ -- Deal with terminating aspect specifications and following semi-
+ -- colon. We skip this in the case of END RECORD, since in this
+ -- case the aspect specifications and semicolon are handled at
+ -- a higher level.
- if Aspect_Specifications_Present then
- if No (Decl) then
- P_Aspect_Specifications (Error);
- else
- P_Aspect_Specifications (Decl);
- end if;
+ if End_Type /= E_Record then
- -- Except in case of END RECORD, semicolon must follow. For END
- -- RECORD, a semicolon does follow, but it is part of a higher level
- -- construct. In any case, a missing semicolon is not serious enough
- -- to consider the END statement to be bad in the sense that we
- -- are dealing with (i.e. to be suspicious that it is not in fact
- -- the END statement we are looking for!)
-
- elsif End_Type /= E_Record then
- if Token = Tok_Semicolon then
- T_Semicolon;
-
- -- Semicolon is missing. If the missing semicolon is at the end
- -- of the line, i.e. we are at the start of the line now, then
- -- a missing semicolon gets flagged, but is not serious enough
- -- to consider the END statement to be bad in the sense that we
- -- are dealing with (i.e. to be suspicious that this END is not
- -- the END statement we are looking for).
-
- -- Similarly, if we are at a colon, we flag it but a colon for
- -- a semicolon is not serious enough to consider the END to be
- -- incorrect. Same thing for a period in place of a semicolon.
-
- elsif Token_Is_At_Start_Of_Line
- or else Token = Tok_Colon
- or else Token = Tok_Dot
- then
- T_Semicolon;
+ -- Scan aspect specifications if permitted here
+
+ if Aspect_Specifications_Present then
+ if No (Decl) then
+ P_Aspect_Specifications (Error);
+ else
+ P_Aspect_Specifications (Decl);
+ end if;
- -- If the missing semicolon is not at the start of the line,
- -- then we do consider the END line to be dubious in this sense.
+ -- If no aspect specifications, must have a semicolon
- else
- End_OK := False;
+ elsif End_Type /= E_Record then
+ if Token = Tok_Semicolon then
+ T_Semicolon;
+
+ -- Semicolon is missing. If the missing semicolon is at the end
+ -- of the line, i.e. we are at the start of the line now, then
+ -- a missing semicolon gets flagged, but is not serious enough
+ -- to consider the END statement to be bad in the sense that we
+ -- are dealing with (i.e. to be suspicious that this END is not
+ -- the END statement we are looking for).
+
+ -- Similarly, if we are at a colon, we flag it but a colon for
+ -- a semicolon is not serious enough to consider the END to be
+ -- incorrect. Same thing for a period in place of a semicolon.
+
+ elsif Token_Is_At_Start_Of_Line
+ or else Token = Tok_Colon
+ or else Token = Tok_Dot
+ then
+ T_Semicolon;
+
+ -- If the missing semicolon is not at the start of the line,
+ -- then we consider the END line to be dubious in this sense.
+
+ else
+ End_OK := False;
+ end if;
end if;
end if;
end if;
-- constructs from this test comes from some internal usage in packed
-- arrays, which otherwise fails, could use more analysis perhaps???
- declare
- function Within_Aspect (N : Node_Id) return Boolean;
- -- True if within aspect expression. Giant kludge, do this test only
- -- within an aspect, since doing it more widely, even though clearly
- -- correct, causes regressions notably in GA19-001 ???
-
- function Within_Aspect (N : Node_Id) return Boolean
- is
- begin
- if No (Parent (N)) then
- return False;
- elsif Nkind (N) = N_Aspect_Specification then
- return True;
- else
- return Within_Aspect (Parent (N));
- end if;
- end Within_Aspect;
-
- begin
- if In_Spec_Expression
- and then Comes_From_Source (N)
- and then not (Is_Entity_Name (P) and then Is_Frozen (Entity (P)))
- and then Within_Aspect (N)
- then
- return;
- end if;
- end;
+ -- We do however go ahead with generic actual types, otherwise we get
+ -- some regressions, probably these types should be frozen anyway???
+
+ if In_Spec_Expression
+ and then Comes_From_Source (N)
+ and then not (Is_Entity_Name (P)
+ and then
+ (Is_Frozen (Entity (P))
+ or else (Is_Type (Entity (P))
+ and then
+ Is_Generic_Actual_Type (Entity (P)))))
+ then
+ return;
+ end if;
-- Acquire first two expressions (at the moment, no attributes take more
-- than two expressions in any case).
OSDN Git Service
