comp.lang.ada
 help / color / mirror / Atom feed
From: Anh Vo <anhvofrcaus@gmail.com>
Subject: Class Wide Type Invariants - My bug or compiler bug
Date: Tue, 25 Feb 2014 19:29:45 -0800 (PST)
Date: 2014-02-25T19:29:45-08:00	[thread overview]
Message-ID: <3b16296c-3a9b-478e-a113-44415f665121@googlegroups.com> (raw)

GNAT did not raise Assertion_Error where I thought it should for the following codes. Either I misunderstood the LRM or it is a compiler bug.

-- places.ads
package Places is

   type Disc_Pt is tagged private
     with Type_Invariant'Class => Check_In (Disc_Pt);

   Initial_Disc_Pt : constant Disc_Pt;

   function Check_In (D : Disc_Pt) return Boolean with Inline;
   
   procedure Set_X_Coord (D : in out Disc_Pt; X : Float)
      with Pre => (X >= -1.0 and then X <= 1.0);

   procedure Set_Y_Coord (D : in out Disc_Pt; Y : Float)
      with Pre => (Y >= -1.0 and then Y <= 1.0);

private
   type Disc_Pt is tagged
      record
         X, Y : Float range -1.0 .. +1.0;
      end record;

   Initial_Disc_Pt : constant Disc_Pt := (others => 0.5);

end Places;

-- places.adb
package body Places is

     function Check_In (D : Disc_Pt) return Boolean is
     begin
        return (D.X**2 + D.Y**2 <= 1.0);
     end Check_In;
     
   procedure Set_X_Coord (D : in out Disc_Pt; X : Float) is
   begin
      D.X := X;
   end Set_X_Coord;

   procedure Set_Y_Coord (D : in out Disc_Pt; Y : Float) is
   begin
      D.Y := Y;
   end Set_Y_Coord;

end Places;

-- places.inner.ads
package Places.Inner is
   
   type Ring_Pt is new Disc_Pt with private
      with Type_Invariant'Class => Check_Out(Ring_Pt);
   Initial_Ring_Pt : constant Ring_Pt;

   function Check_Out (R : Ring_Pt) return Boolean
     with Inline;

private
   type Ring_Pt is new Disc_Pt with null record;

   Initial_Ring_Pt : constant Ring_Pt := Ring_Pt'(Initial_Disc_Pt with null record);

   function Check_Out (R : Ring_Pt) return Boolean is
     (R.X**2 + R.Y**2 >= 0.25);

end Places.Inner;


-- invariants_inheritance_test.adb
with Ada.Text_Io;
with Ada.Exceptions; use Ada;

with Places.Inner;

procedure Invariants_Inheritance_Test is
   use Text_Io;

   Child_Pt : Places.Inner.Ring_Pt := Places.Inner.Initial_Ring_Pt;

begin

   Places.Inner.Set_X_Coord(Child_Pt, 0.0);  -- OK since 0.5**2 + 0.0 >= 0.25
   Places.Inner.Set_Y_Coord(Child_Pt, 0.1);  -- should fail Check_Out(...), 
                                             -- 0.1**2 + 0.0 < 0.25
exception
   when Err : others =>
      Put_Line ("Houston help!!! " & Exceptions.Exception_Information(Err));

end Invariants_Inheritance_Test;


             reply	other threads:[~2014-02-26  3:29 UTC|newest]

Thread overview: 5+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2014-02-26  3:29 Anh Vo [this message]
2014-02-26 22:35 ` Class Wide Type Invariants - My bug or compiler bug adambeneschan
2014-02-26 23:59   ` Anh Vo
2014-02-27  1:01   ` Randy Brukardt
2014-02-27  1:16     ` adambeneschan
replies disabled

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox