+2015-02-05 Javier Miranda <miranda@adacore.com>
+
+ * errout.adb (Error_Msg_PT): Add missing error.
+ * sem_ch6.adb (Check_Synchronized_Overriding): Check the missing
+ RM rule. Code cleanup.
+ * exp_ch9.adb (Build_Wrapper_Spec): Propagate "constant" in
+ anonymous access types. Found working on the tests. Code cleanup.
+
+2015-02-05 Vincent Celier <celier@adacore.com>
+
+ * prj-dect.adb (Parse_Attribute_Declaration): Continue scanning
+ when there are incomplete withs.
+ * prj-nmsc.adb (Process_Naming): Do not try to get the value
+ of an element when it is nil.
+ (Check_Naming): Do not check a nil suffix for illegality
+ * prj-proc.adb (Expression): Do not process an empty term.
+ * prj-strt.adb (Attribute_Reference): If attribute cannot be
+ found, parse a possible index to avoid cascading errors.
+
+2015-02-05 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aux.adb (Is_Derived_Type): A subprogram_type generated
+ for an access_to_subprogram declaration is not a derived type.
+
2015-02-05 Robert Dewar <dewar@adacore.com>
* errout.adb (Error_Msg_Internal): For non-serious error set
("illegal overriding of subprogram inherited from interface", E);
Error_Msg_Sloc := Sloc (Iface_Prim);
- Error_Msg_N
- ("\first formal of & declared # must be of mode `OUT`, `IN OUT` " &
- "or access-to-variable", E);
+
+ if Ekind (E) = E_Function then
+ Error_Msg_N
+ ("\first formal of & declared # must be of mode `IN` " &
+ "or access-to-constant", E);
+ else
+ Error_Msg_N
+ ("\first formal of & declared # must be of mode `OUT`, `IN OUT` " &
+ "or access-to-variable", E);
+ end if;
end Error_Msg_PT;
-----------------
-- --
-- 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- --
Obj_Param_Typ :=
Make_Access_Definition (Loc,
Subtype_Mark =>
- New_Occurrence_Of (Obj_Typ, Loc));
- Set_Null_Exclusion_Present (Obj_Param_Typ,
- Null_Exclusion_Present (Parameter_Type (First_Param)));
-
+ New_Occurrence_Of (Obj_Typ, Loc),
+ Null_Exclusion_Present =>
+ Null_Exclusion_Present (Parameter_Type (First_Param)),
+ Constant_Present =>
+ Constant_Present (Parameter_Type (First_Param)));
else
Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc);
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
The_Project := Imported_Or_Extended_Project_Of
(Current_Project, In_Tree, Token_Name);
- if No (The_Project) then
+ if No (The_Project) and then not In_Tree.Incomplete_With then
Error_Msg (Flags, "unknown project", Location);
Scan (In_Tree); -- past the project name
Get_Name_String
(Name_Of (Current_Package, In_Tree)),
Token_Ptr);
+ Scan (In_Tree); -- past the package name
else
- The_Package :=
- First_Package_Of (The_Project, In_Tree);
-
- -- Look for the package node
-
- while Present (The_Package)
- and then
- Name_Of (The_Package, In_Tree) /= Token_Name
- loop
+ if Present (The_Project) then
The_Package :=
- Next_Package_In_Project
- (The_Package, In_Tree);
- end loop;
-
- -- If the package cannot be found in the
- -- project, issue an error.
-
- if No (The_Package) then
- The_Project := Empty_Node;
- Error_Msg_Name_2 := Project_Name;
- Error_Msg_Name_1 := Token_Name;
- Error_Msg
- (Flags,
- "package % not declared in project %",
- Token_Ptr);
+ First_Package_Of (The_Project, In_Tree);
+
+ -- Look for the package node
+
+ while Present (The_Package)
+ and then
+ Name_Of (The_Package, In_Tree) /=
+ Token_Name
+ loop
+ The_Package :=
+ Next_Package_In_Project
+ (The_Package, In_Tree);
+ end loop;
+
+ -- If the package cannot be found in the
+ -- project, issue an error.
+
+ if No (The_Package) then
+ The_Project := Empty_Node;
+ Error_Msg_Name_2 := Project_Name;
+ Error_Msg_Name_1 := Token_Name;
+ Error_Msg
+ (Flags,
+ "package % not declared in project %",
+ Token_Ptr);
+ end if;
end if;
Scan (In_Tree); -- past the package name
end if;
end if;
- if Present (The_Project) then
+ if Present (The_Project) or else In_Tree.Incomplete_With then
-- Looking for '<same attribute name>
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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- --
Lang_Index := Get_Language_From_Name
(Project, Get_Name_String (Element.Index));
- if Lang_Index /= No_Language_Index then
+ if Lang_Index /= No_Language_Index and then
+ Element.Value.Kind = Single and then
+ Element.Value.Value /= No_Name
+ then
case Current_Array.Name is
when Name_Spec_Suffix | Name_Specification_Suffix =>
Shared => Shared);
end if;
- if Suffix /= Nil_Variable_Value then
+ if Suffix /= Nil_Variable_Value and then
+ Suffix.Value /= No_Name
+ then
Lang_Id.Config.Naming_Data.Spec_Suffix :=
File_Name_Type (Suffix.Value);
Shared => Shared);
end if;
- if Suffix /= Nil_Variable_Value then
+ if Suffix /= Nil_Variable_Value and then
+ Suffix.Value /= No_Name
+ then
Lang_Id.Config.Naming_Data.Body_Suffix :=
File_Name_Type (Suffix.Value);
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
The_Term := First_Term;
while Present (The_Term) loop
The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree);
- Current_Term_Kind :=
- Kind_Of (The_Current_Term, From_Project_Node_Tree);
- case Current_Term_Kind is
+ if The_Current_Term /= Empty_Node then
+ Current_Term_Kind :=
+ Kind_Of (The_Current_Term, From_Project_Node_Tree);
+
+ case Current_Term_Kind is
when N_Literal_String =>
else
Shared.String_Elements.Table
(Last).Next := String_Element_Table.Last
- (Shared.String_Elements);
+ (Shared.String_Elements);
end if;
Last := String_Element_Table.Last
Shared.String_Elements.Table (Last) :=
(Value => String_Value_Of
- (The_Current_Term,
- From_Project_Node_Tree),
+ (The_Current_Term,
+ From_Project_Node_Tree),
Index => Source_Index_Of
(The_Current_Term,
From_Project_Node_Tree),
The_Package := The_Project.Decl.Packages;
while The_Package /= No_Package
and then Shared.Packages.Table (The_Package).Name /=
- The_Name
+ The_Name
loop
The_Package :=
Shared.Packages.Table (The_Package).Next;
(The_Package /= No_Package, "package not found.");
elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) =
- N_Attribute_Reference
+ N_Attribute_Reference
then
The_Package := No_Package;
end if;
else
if Expression_Kind_Of
- (The_Current_Term, From_Project_Node_Tree) =
- List
+ (The_Current_Term, From_Project_Node_Tree) =
+ List
then
The_Variable :=
(Project => Project,
else
Shared.String_Elements.Table (Last).Next :=
- String_Element_Table.Last
- (Shared.String_Elements);
+ String_Element_Table.Last
+ (Shared.String_Elements);
end if;
Last :=
(Value => The_Variable.Value,
Display_Value => No_Name,
Location => Location_Of
- (The_Current_Term,
- From_Project_Node_Tree),
+ (The_Current_Term,
+ From_Project_Node_Tree),
Flag => False,
Next => Nil_String,
Index => 0);
Index => 0);
The_List := Shared.String_Elements.Table
- (The_List).Next;
+ (The_List).Next;
end loop;
end;
end case;
String_Element_Table.Increment_Last
(Shared.String_Elements);
Shared.String_Elements.Table (Last).Next :=
- String_Element_Table.Last
- (Shared.String_Elements);
+ String_Element_Table.Last
+ (Shared.String_Elements);
Last := String_Element_Table.Last
- (Shared.String_Elements);
+ (Shared.String_Elements);
end if;
end loop;
"illegal node kind in an expression");
raise Program_Error;
- end case;
+ end case;
+ end if;
The_Term := Next_Term (The_Term, From_Project_Node_Tree);
end loop;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
Scan (In_Tree);
+ -- Skip a possible index for an associative array
+
+ if Token = Tok_Left_Paren then
+ Scan (In_Tree);
+
+ if Token = Tok_String_Literal then
+ Scan (In_Tree);
+
+ if Token = Tok_Right_Paren then
+ Scan (In_Tree);
+ end if;
+ end if;
+ end if;
+
else
-- Give its characteristics to this attribute reference
-- --
-- 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- --
if Is_Type (Ent)
and then Base_Type (Ent) /= Root_Type (Ent)
and then not Is_Class_Wide_Type (Ent)
+ and then Ekind (Ent) /= E_Subprogram_Type
then
if not Is_Numeric_Type (Root_Type (Ent)) then
return True;
declare
Candidate : Entity_Id := Empty;
Hom : Entity_Id := Empty;
- Iface_Typ : Entity_Id;
Subp : Entity_Id := Empty;
begin
and then Etype (Result_Definition (Parent (Def_Id))) =
Etype (Result_Definition (Parent (Subp)))
then
- Overridden_Subp := Subp;
- return;
+ Candidate := Subp;
+
+ -- If an inherited subprogram is implemented by a protected
+ -- function, then the first parameter of the inherited
+ -- subprogram shall be of mode in, but not an
+ -- access-to-variable parameter (RM 9.4(11/9)
+
+ if Present (First_Formal (Subp))
+ and then Ekind (First_Formal (Subp)) = E_In_Parameter
+ and then
+ (not Is_Access_Type (Etype (First_Formal (Subp)))
+ or else
+ Is_Access_Constant (Etype (First_Formal (Subp))))
+ then
+ Overridden_Subp := Subp;
+ return;
+ end if;
end if;
Hom := Homonym (Hom);
-- After examining all candidates for overriding, we are left with
-- the best match which is a mode incompatible interface routine.
- -- Do not emit an error if the Expander is active since this error
- -- will be detected later on after all concurrent types are
- -- expanded and all wrappers are built. This check is meant for
- -- spec-only compilations.
-
- if Present (Candidate) and then not Expander_Active then
- Iface_Typ :=
- Find_Parameter_Type (Parent (First_Formal (Candidate)));
-
- -- Def_Id is primitive of a protected type, declared inside the
- -- type, and the candidate is primitive of a limited or
- -- synchronized interface.
- if In_Scope
- and then Is_Protected_Type (Typ)
- and then
- (Is_Limited_Interface (Iface_Typ)
- or else Is_Protected_Interface (Iface_Typ)
- or else Is_Synchronized_Interface (Iface_Typ)
- or else Is_Task_Interface (Iface_Typ))
- then
- Error_Msg_PT (Def_Id, Candidate);
- end if;
+ if In_Scope and then Present (Candidate) then
+ Error_Msg_PT (Def_Id, Candidate);
end if;
Overridden_Subp := Candidate;
projects / gcc.git / commitdiff