+2017-04-25 Bob Duff <duff@adacore.com>
+
+ * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
+ Use Source_Index (Current_Sem_Unit) to find the correct casing.
+ * exp_prag.adb (Expand_Pragma_Check): Use Source_Index
+ (Current_Sem_Unit) to find the correct casing.
+ * par.adb (Par): Null out Current_Source_File, to ensure that
+ the above bugs won't rear their ugly heads again.
+
+2017-04-25 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch8.adb (Find_Type): For an attribute reference
+ 'Class, if prefix type is synchronized and previous errors
+ have suppressed the creation of the corresponding record type,
+ create a spurious class-wide for the synchonized type itself,
+ to catch other misuses of the attribute
+
+2017-04-25 Steve Baird <baird@adacore.com>
+
+ * exp_ch6.adb (Expand_Simple_Function_Return): if CodePeer_Mode
+ is True, then don't generate the accessibility check for the
+ tag of a tagged result.
+ * exp_intr.adb (Expand_Dispatching_Constructor_Call):
+ if CodePeer_Mode is True, then don't generate the
+ tag checks for the result of call to an instance of
+ Ada.Tags.Generic_Dispatching_Constructor (i.e., both the "is a
+ descendant of" check and the accessibility check).
+
+2017-04-25 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb: Code cleanups.
+ * a-strbou.ads: minor whitespace fix in Trim for bounded strings.
+ * sem_ch8.ads: Minor comment fix.
+
2017-04-25 Eric Botcazou <ebotcazou@adacore.com>
* exp_ch4.adb (Library_Level_Target): New function.
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
function Trim
(Source : Bounded_String;
- Left : Maps.Character_Set;
- Right : Maps.Character_Set) return Bounded_String;
+ Left : Maps.Character_Set;
+ Right : Maps.Character_Set) return Bounded_String;
procedure Trim
(Source : in out Bounded_String;
Attribute_Name => Name_Tag);
end if;
- Insert_Action (Exp,
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
- Reason => PE_Accessibility_Check_Failed));
+ if not CodePeer_Mode then
+ -- CodePeer doesn't do anything useful with
+ -- Ada.Tags.Type_Specific_Data components
+
+ Insert_Action (Exp,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
+ Reason => PE_Accessibility_Check_Failed));
+ end if;
end;
-- AI05-0073: If function has a controlling access result, check that
Result_Typ := Class_Wide_Type (Etype (Act_Constr));
-- Check that the accessibility level of the tag is no deeper than that
- -- of the constructor function.
+ -- of the constructor function (unless CodePeer_Mode)
- Insert_Action (N,
- Make_Implicit_If_Statement (N,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd =>
- Build_Get_Access_Level (Loc, New_Copy_Tree (Tag_Arg)),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Scope_Depth (Act_Constr))),
-
- Then_Statements => New_List (
- Make_Raise_Statement (Loc,
- New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
+ if not CodePeer_Mode then
+ Insert_Action (N,
+ Make_Implicit_If_Statement (N,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Build_Get_Access_Level (Loc, New_Copy_Tree (Tag_Arg)),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Scope_Depth (Act_Constr))),
+
+ Then_Statements => New_List (
+ Make_Raise_Statement (Loc,
+ New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
+ end if;
if Is_Interface (Etype (Act_Constr)) then
-- Do not generate a run-time check on the built object if tag
-- checks are suppressed for the result type or tagged type expansion
- -- is disabled.
+ -- is disabled or if CodePeer_Mode.
if Tag_Checks_Suppressed (Etype (Result_Typ))
or else not Tagged_Type_Expansion
+ or else CodePeer_Mode
then
null;
with Exp_Util; use Exp_Util;
with Expander; use Expander;
with Inline; use Inline;
+with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
Add_Str_To_Name_Buffer ("failed invariant from ");
-- For all other checks, the string is "xxx failed at yyy"
- -- where xxx is the check name with current source file casing.
+ -- where xxx is the check name with appropriate casing.
else
Get_Name_String (Nam);
- Set_Casing (Identifier_Casing (Current_Source_File));
+ Set_Casing
+ (Identifier_Casing (Source_Index (Current_Sem_Unit)));
Add_Str_To_Name_Buffer (" failed at ");
end if;
procedure Labl is separate;
procedure Load is separate;
+ Result : List_Id := Empty_List;
+
-- Start of processing for Par
begin
begin
loop
if Token = Tok_EOF then
- Compiler_State := Analyzing;
- return Pragmas;
+ Result := Pragmas;
+ exit;
elsif Token /= Tok_Pragma then
Error_Msg_SC ("only pragmas allowed in configuration file");
- Compiler_State := Analyzing;
- return Error_List;
+ Result := Error_List;
+ exit;
else
P_Node := P_Pragma;
Restore_Opt_Config_Switches (Save_Config_Switches);
Set_Comes_From_Source_Default (False);
- Compiler_State := Analyzing;
- return Empty_List;
end if;
+
+ Compiler_State := Analyzing;
+ Current_Source_File := No_Source_File;
+ return Result;
end Par;
end if;
-- A variable is most likely modified from the outside. Take
- -- Take the optimistic approach to avoid spurious errors.
+ -- the optimistic approach to avoid spurious errors.
if Ekind (E) = E_Variable then
Set_Never_Set_In_Source (E, False);
end if;
-- Check that the class-wide predicate cannot be applied to
- -- an operation of a synchronized type that is not a tagged
- -- type. Other legality checks are performed when analyzing
- -- the contract of the operation.
+ -- an operation of a synchronized type. AI12-0182 forbids
+ -- these altogether, while earlier language semantics made
+ -- them legal on tagged synchronized types.
+
+ -- Other legality checks are performed when analyzing the
+ -- contract of the operation.
if Class_Present (Aspect)
and then Is_Concurrent_Type (Current_Scope)
- and then not Is_Tagged_Type (Current_Scope)
and then Ekind_In (E, E_Entry, E_Function, E_Procedure)
then
Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Aspect);
if Is_Concurrent_Type (T) then
if No (Corresponding_Record_Type (Entity (Prefix (N)))) then
- -- Previous error. Use current type, which at least
- -- provides some operations.
+ -- Previous error. Create a class-wide type for the
+ -- synchronized type itself, with minimal semantic
+ -- attributes, to catch other errors in some ACATS tests.
- C := Entity (Prefix (N));
+ pragma Assert (Serious_Errors_Detected > 0);
+ Make_Class_Wide_Type (T);
+ C := Class_Wide_Type (T);
+ Set_First_Entity (C, First_Entity (T));
else
C := Class_Wide_Type
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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 Set_Use (L : List_Id);
-- Find use clauses that are declarative items in a package declaration
- -- and set the potentially use-visible flags of imported entities before
+ -- and set the potentially use-visible flags of imported entities before
-- analyzing the corresponding package body.
procedure ws;
if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
Set_Casing
- (Identifier_Casing (Current_Source_File));
+ (Identifier_Casing
+ (Source_Index (Current_Sem_Unit)));
Error_Msg_String (1 .. Rnm'Length) :=
Name_Buffer (1 .. Name_Len);
Error_Msg_Strlen := Rnm'Length;
projects / gcc.git / commitdiff