@@ -577,6 +577,7 @@ package body Checks is
Typ : Entity_Id;
Insert_Node : Node_Id)
is
+ Check_Cond : Node_Id;
Loc : constant Source_Ptr := Sloc (N);
Param_Ent : Entity_Id := Param_Entity (N);
Param_Level : Node_Id;
@@ -638,15 +639,29 @@ package body Checks is
-- Raise Program_Error if the accessibility level of the access
-- parameter is deeper than the level of the target access type.
+ Check_Cond := Make_Op_Gt (Loc,
+ Left_Opnd => Param_Level,
+ Right_Opnd => Type_Level);
+
Insert_Action (Insert_Node,
Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => Param_Level,
- Right_Opnd => Type_Level),
- Reason => PE_Accessibility_Check_Failed));
+ Condition => Check_Cond,
+ Reason => PE_Accessibility_Check_Failed));
Analyze_And_Resolve (N);
+
+ -- If constant folding has happened on the condition for the
+ -- generated error, then warn about it being unconditional.
+
+ if Nkind (Check_Cond) = N_Identifier
+ and then Entity (Check_Cond) = Standard_True
+ then
+ Error_Msg_Warn := SPARK_Mode /= On;
+ Error_Msg_N
+ ("accessibility check fails<<", N);
+ Error_Msg_N
+ ("\Program_Error [<<", N);
+ end if;
end if;
end Apply_Accessibility_Check;
new file mode 100644
@@ -0,0 +1,79 @@
+-- { dg-do run }
+
+with Interfaces; use Interfaces;
+
+procedure Access7 is
+ type t_p_string is access constant String;
+ subtype t_hash is Unsigned_32;
+
+ -- Return a hash value for a given string
+ function hash(s: String) return t_hash is
+ h: t_hash := 0;
+ g: t_hash;
+ begin
+ for i in s'Range loop
+ h := Shift_Left(h, 4) + t_hash'(Character'Pos(s(i)));
+ g := h and 16#F000_0000#;
+ if (h and g) /= 0 then
+ h := h xor ((Shift_Right(g, 24) and 16#FF#) or g);
+ end if;
+ end loop;
+ return h;
+ end hash;
+
+ type hash_entry is record
+ v: t_p_string;
+ hash: t_hash;
+ next: access hash_entry;
+ end record;
+
+ type hashtable is array(t_hash range <>) of access hash_entry;
+
+ protected pool is
+ procedure allocate (sp: out t_p_string; s: String; h: t_hash);
+ private
+ tab: hashtable(0..199999-1) := (others => null);
+ end pool;
+
+ protected body pool is
+ procedure allocate(sp: out t_p_string; s: String; h: t_hash) is
+ p: access hash_entry;
+ slot: t_hash;
+ begin
+ slot := h mod tab'Length;
+ p := tab(slot);
+ while p /= null loop
+ -- quickly check hash, then length, only then slow comparison
+ if p.hash = h and then p.v.all'Length = s'Length
+ and then p.v.all = s
+ then
+ sp := p.v; -- shared string
+ return;
+ end if;
+ p := p.next;
+ end loop;
+ -- add to table
+ p := new hash_entry'(v => new String'(s),
+ hash => h,
+ next => tab(slot));
+ tab(slot) := p; -- { dg-warning "accessibility check fails|Program_Error will be raised at run time" }
+ sp := p.v; -- shared string
+ end allocate;
+ end pool;
+
+ -- Return the pooled string equal to a given String
+ function new_p_string(s: String) return t_p_string is
+ sp: t_p_string;
+ begin
+ pool.allocate(sp, s, hash(s));
+ return sp;
+ end new_p_string;
+
+ foo_string : t_p_string;
+begin
+ foo_string := new_p_string("foo");
+ raise Constraint_Error;
+exception
+ when Program_Error =>
+ null;
+end Access7;