This restores the original computation of the scope depth of the innermost
enclosing master of a given node and performs a couple of other cleanups.
Note that this has uncovered an issue in the ACATS
c3a0025 test and the
change contains the modification that has been submitted to the ACAA.
gcc/ada/
PR ada/124369
* accessibility.adb (Accessibility_Message): Give an error instead
of a warning in an instance when No_Dynamic_Accessibility_Checks is
in effect.
(Innermost_Master_Scope_Depth): Restore the original computation of
the nearest enclosing dynamic scope.
* sem_attr.adb (Resolve_Attribute) <Attribute_Access>: Call the
Accessibility_Message routine in all cases to give accessibility
errors and do not return. Call the Static_Accessibility_Level
function in all cases to compute static accessibility levels.
Add guard before calling Prefix_With_Safe_Accessibility_Level.
gcc/testsuite/
* ada/acats-3/tests/c3/
c3a0025.a: Tweak.
* ada/acats-4/tests/c3/
c3a0025.a: Likewise.
* gnat.dg/access12.adb: New test.
begin
-- In an instance, this is a runtime check, but one we know will fail,
- -- so generate an appropriate warning.
+ -- so generate an appropriate warning. As usual, this kind of warning
+ -- is an error in SPARK mode or if No_Dynamic_Accessibility_Checks.
if In_Instance_Body then
- Error_Msg_Warn := SPARK_Mode /= On;
+ Error_Msg_Warn := SPARK_Mode /= On
+ and then not
+ No_Dynamic_Accessibility_Checks_Enabled (P);
Error_Msg_F
("non-local pointer cannot point to local object<<", P);
Error_Msg_F ("\Program_Error [<<", P);
begin
-- Locate the nearest enclosing node (by traversing Parents)
-- that Defining_Entity can be applied to, and return the
- -- depth of that entity's nearest enclosing scope.
+ -- depth of that entity's nearest enclosing dynamic scope.
-- The RM 7.6.1(3) definition of "master" includes statements
-- and conditions for loops among other things. Are these cases
Ent := Defining_Entity_Or_Empty (Node_Par);
if Present (Ent) then
- -- X'Old is nested within the current subprogram, so we do not
- -- want Find_Enclosing_Scope of that subprogram. If this is an
- -- allocator, then we're looking for the innermost master of
- -- the call, so again we do not want Find_Enclosing_Scope.
-
- if (Nkind (N) = N_Attribute_Reference
- and then Attribute_Name (N) = Name_Old)
- or else Nkind (N) = N_Allocator
- then
- Encl_Scop := Ent;
- else
- Encl_Scop := Find_Enclosing_Scope (Ent);
- end if;
+ Encl_Scop := Nearest_Dynamic_Scope (Ent);
-- Ignore transient scopes made during expansion while also
-- taking into account certain expansions - like iterators
Static_Accessibility_Level (N, Zero_On_Dynamic_Level) >
Deepest_Type_Access_Level (Btyp)
then
- -- In an instance, this is a runtime check, but one we know
- -- will fail, so generate an appropriate warning. As usual,
- -- this kind of warning is an error in SPARK mode.
-
- if In_Instance_Body then
- Error_Msg_Warn :=
- SPARK_Mode /= On
- and then
- not No_Dynamic_Accessibility_Checks_Enabled (P);
-
- Error_Msg_F
- ("non-local pointer cannot point to local object<<", P);
- Error_Msg_F ("\Program_Error [<<", P);
-
- Rewrite (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Accessibility_Check_Failed));
- Set_Etype (N, Typ);
-
- else
- Error_Msg_F
- ("non-local pointer cannot point to local object", P);
- end if;
+ Accessibility_Message (N, Typ);
end if;
if Attr_Id /= Attribute_Unrestricted_Access
and then Ekind (Btyp)
= E_Anonymous_Access_Type)
- -- Call Accessibility_Level directly to avoid returning
- -- zero on cases where the prefix is an explicitly aliased
- -- parameter in a return statement, instead of using the
- -- normal Static_Accessibility_Level function.
-
- -- Shouldn't this be handled somehow in
- -- Static_Accessibility_Level ???
-
- and then Nkind (Accessibility_Level (P, Dynamic_Level))
- = N_Integer_Literal
and then
- Intval (Accessibility_Level (P, Dynamic_Level))
- > Deepest_Type_Access_Level (Btyp)
+ Static_Accessibility_Level (N, Zero_On_Dynamic_Level) >
+ Deepest_Type_Access_Level (Btyp)
then
Accessibility_Message (N, Typ);
- return;
end if;
end;
end if;
and then Attr_Id /= Attribute_Unrestricted_Access
then
Accessibility_Message (N, Typ);
- return;
-- AI05-0225: If the context is not an access to protected
-- function, the prefix must be a variable, given that it may
-- array type since a value conversion is like an aggregate with
-- respect to determining accessibility level (RM 3.10.2).
- if not Prefix_With_Safe_Accessibility_Level (N, Typ) then
+ if Nkind (N) /= N_Raise_Program_Error
+ and then not Prefix_With_Safe_Accessibility_Level (N, Typ)
+ then
Accessibility_Message (N, Typ);
- return;
end if;
-- Mark that address of entity is taken in case of
when Constraint_Error =>
null;
end;
- Obj := Func_1 (Non_Null_Init);
- if Obj /= Non_Null_Init then
+ -- Temporary deviation from the original test:
+ -- Obj := Func_1 (Non_Null_Init);
+ -- if Obj /= Non_Null_Init then
+
+ if Func_1 (Non_Null_Init) /= Non_Null_Init then
Report.Failed ("Func_1_OK: Wrong value");
end if;
end;
when Constraint_Error =>
null;
end;
- Obj := Func_2 (Non_Null_Init);
- if Obj /= Non_Null_Init then
+ -- Temporary deviation from the original test:
+ -- Obj := Func_2 (Non_Null_Init);
+ -- if Obj /= Non_Null_Init then
+
+ if Func_2 (Non_Null_Init) /= Non_Null_Init then
Report.Failed ("Func_2_OK: Wrong value");
end if;
end;
when Constraint_Error =>
null;
end;
- Obj := Func_1 (Non_Null_Init);
- if Obj /= Non_Null_Init then
+ -- Temporary deviation from the original test:
+ -- Obj := Func_1 (Non_Null_Init);
+ -- if Obj /= Non_Null_Init then
+
+ if Func_1 (Non_Null_Init) /= Non_Null_Init then
Report.Failed ("Func_1_OK: Wrong value");
end if;
end;
when Constraint_Error =>
null;
end;
- Obj := Func_2 (Non_Null_Init);
- if Obj /= Non_Null_Init then
+ -- Temporary deviation from the original test:
+ -- Obj := Func_2 (Non_Null_Init);
+ -- if Obj /= Non_Null_Init then
+
+ if Func_2 (Non_Null_Init) /= Non_Null_Init then
Report.Failed ("Func_2_OK: Wrong value");
end if;
end;
--- /dev/null
+-- { dg-do compile }
+
+procedure Access12 is
+
+ type Rec (Element : access Integer) is null record;
+
+ function Make_Rec (X : access Integer) return Rec is (Element => X);
+
+ type Acc is access all Integer;
+
+ A : Acc;
+
+begin
+ for I in 1 .. 10 loop
+ declare
+ X : aliased Integer;
+ R : Rec := Make_Rec (X'Access);
+ begin
+ if I = 1 then
+ X := 0;
+ end if;
+ A := R.Element.all'Access; -- { dg-error "non-local pointer" }
+ X := I;
+ end;
+ end loop;
+end;
projects / thirdparty / gcc.git / commitdiff
