From mboxrd@z Thu Jan  1 00:00:00 1970
X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on polar.synack.me
X-Spam-Level: 
X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00,FREEMAIL_FROM
	autolearn=unavailable autolearn_force=no version=3.4.4
X-Received: by 10.66.144.228 with SMTP id sp4mr2254254pab.5.1393385385759;
        Tue, 25 Feb 2014 19:29:45 -0800 (PST)
X-Received: by 10.182.117.138 with SMTP id ke10mr243obb.42.1393385385387; Tue,
 25 Feb 2014 19:29:45 -0800 (PST)
Path: 
 eternal-september.org!reader01.eternal-september.org!reader02.eternal-september.org!news.eternal-september.org!news.eternal-september.org!news.eternal-september.org!feeder.eternal-september.org!news.glorb.com!uq10no3679113igb.0!news-out.google.com!h8ni98igy.0!nntp.google.com!uq10no3679104igb.0!postnews.google.com!glegroupsg2000goo.googlegroups.com!not-for-mail
Newsgroups: comp.lang.ada
Date: Tue, 25 Feb 2014 19:29:45 -0800 (PST)
Complaints-To: groups-abuse@google.com
Injection-Info: glegroupsg2000goo.googlegroups.com;
 posting-host=149.32.224.33;
 posting-account=Qh2kiQoAAADpCLlhT_KTYoGO8dU3n4I6
NNTP-Posting-Host: 149.32.224.33
User-Agent: G2/1.0
MIME-Version: 1.0
Message-ID: <3b16296c-3a9b-478e-a113-44415f665121@googlegroups.com>
Subject: Class Wide Type Invariants - My bug or compiler bug
From: Anh Vo <anhvofrcaus@gmail.com>
Injection-Date: Wed, 26 Feb 2014 03:29:45 +0000
Content-Type: text/plain; charset=ISO-8859-1
Xref: news.eternal-september.org comp.lang.ada:18747
Date: 2014-02-25T19:29:45-08:00
List-Id: <comp.lang.ada>

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;