[Bug ada/29781] New: -O3 -gnatVa triggers a bug box on working Dragonchess code

["prosfilaes at gmail dot com" <gcc-bugzilla at gcc dot gnu dot org>]

I've added the bug box and the code below. This code compiled fine with
previous versions of GNAT, and with -O2 or without -gnatVa. 

gcc-4.1 -c -I./ -gnatVa  -O3 iterate_moves.adb
+===========================GNAT BUG DETECTED==============================+
| 4.1.2 20061028 (prerelease) (Debian 4.1.1-19) (x86_64-pc-linux-gnu) GCC
error:|
| in simplify_cond_and_lookup_avail_expr, at tree-ssa-dom.c:2111           |
| Error detected at iterate_moves.adb:147:1                                |
| Please submit a bug report; see http://gcc.gnu.org/bugs.html.            |
| Use a subject line meaningful to you and us to track the bug.            |
| Include the entire contents of this bug box in the report.               |
| Include the exact gcc-4.1 or gnatmake command that you entered.          |
| Also include sources listed below in gnatchop format                     |
| (concatenated together with no headers between files).                   |
+==========================================================================+

Please include these source files with error report
Note that list may not be accurate in some cases, 
so please double check that the problem can still 
be reproduced with the set of files listed.

iterate_moves.adb
iterate_moves.ads
board_types.ads
iterate_moves-next_piece.adb


raised TYPES.UNRECOVERABLE_ERROR : comperr.adb:380

with Interfaces;

--  Board_Types contains all the fundamental types representing the game.
package Board_Types is

   --  Board_Types is and should continue to be conceptually pure. No
   --  global data or state.
   pragma Pure (Board_Types);

   type Board_Layer_Type is (Upper, Middle, Lower);

   type Piece_Type is
     (Sylph, Griffon,
      Dragon, King, Mage, Paladin, Thief,
      Cleric, Hero, Unicorn, Oliphant, Warrior, Dwarf, Basilisk,
      Elemental);
   type Player_Type is (Scarlet, Gold);
   type Board_Piece (Exists : Boolean := False) is record
      case Exists is
         when True =>
            Piece : Piece_Type;
            Player : Player_Type;
         when False =>
            null;
      end case;
   end record;
   type Row_Type is range 1 .. 8;
   type Column_Type is range 1 .. 12;
   type Board_Layer is array (Row_Type, Column_Type) of Board_Piece;
   type Board is array (Board_Layer_Type) of Board_Layer;
   type Board_Location is record
      Layer : Board_Layer_Type;
      Row : Row_Type;
      Column : Column_Type;
   end record;

   Initial_Board : constant Board := (others => (others => (others => (Exists
=> False))));
   --  Helper functions

   function "not" (P : Player_Type) return Player_Type;
   pragma Inline ("not");

end Board_Types;
-- with Validate; use Validate;

package body Iterate_Moves is

    function Next_Piece (C: Player_Type; Piece: Board_Location; B : Board)
                        return Board_Location
      is separate;

   subtype Int is Integer;

   --  Pawn_Advance/Retreat is to avoid having two type conversions
   --  all over the place. They should be completely inlined.
   function Pawn_Advance (R : Row_Type; C : Player_Type) return Row_Type is
   begin
      if C = Scarlet then
         return R - 1;
      else
         return R + 1;
      end if;
   end Pawn_Advance;
   pragma Inline (Pawn_Advance);

   function Pawn_Retreat (R : Row_Type; C : Player_Type) return Row_Type is
   begin
      if C = Scarlet then
         return R + 1;
      else
         return R - 1;
      end if;
   end Pawn_Retreat;
   pragma Inline (Pawn_Retreat);

   function Increment (C : Player_Type; I : Board_Move; B : Board)
                      return Board_Move;

   function Inc (C : Player_Type; Start : Board_Location; B :Board)
                return Board_Move
   is
   begin
      return Increment
        (C,
         (Next_Piece (C, Start, B), (Upper, 1, 1), Increment, 0),
         B);
   end Inc;
   pragma Inline (Inc);

   function Sylph_Increment
     (C : Player_Type; Start : Board_Location; Move_Number_In : Natural; B :
Board)
     return Board_Move
   is
      Move_Number : Natural := Move_Number_In;
      Orig_Row : Row_Type;
   begin

      if (Start.Layer = Upper and Move_Number > 4) or
        (Start.Layer = Middle and Move_Number > 7) then
         return Inc (C, Start, B);
      end if;

        case Start.Layer is
           when Upper =>
              loop
                 case Move_Number is

                    when others =>
                       raise Program_Error;
                 end case;
              end loop;
           when Middle =>
              if C = Scarlet then
                 Orig_Row := 7;
              else
                 Orig_Row := 2;
              end if;
              loop
                 case Move_Number is
                      when 1 =>
                         if not B (Upper) (Start.Row, Start.Column).Exists then
                            return (Start,
                                    (Upper, Start.Row, Start.Column),
                                    True_Move, Move_Number);
                         else
                            Move_Number := 2;
                         end if;
                      when 2 .. 6 =>
                         if not B (Upper) (Orig_Row,
                                           Column_Type (Move_Number * 2 -
3)).Exists
                           and not (Orig_Row = Start.Row and
                                    Column_Type (Move_Number * 2 - 3) =
Start.Column)
                         then
                            return (Start,
                                    (Upper, Orig_Row, Column_Type (Move_Number
* 2 - 3)),
                                    True_Move, Move_Number);
                         else
                            Move_Number := Move_Number + 1;
                        end if;
                      when 7 =>
                         -- 7 * 2 - 3 = 11
                         if not B (Upper) (Orig_Row, 11).Exists and
                           not (Orig_Row = Start.Row and 11 = Start.Column)
                         then
                            return (Start,
                                    (Upper, Orig_Row, 11),
                                    True_Move, Move_Number);
                         else
                            return Inc (C, Start, B);
                         end if;
                    when others =>
                       raise Program_Error;
                 end case;
              end loop;
           when Lower =>
                    -- Shouldn't reach here if assertions are turned on
              raise Program_Error;
        end case;
   end Sylph_Increment;

   function Increment (C : Player_Type; I : Board_Move; B : Board)
                      return Board_Move
   is
      Start : Board_Location renames I.Start_Loc;
      Move_Number : Natural := I.Move_Number;
   begin

      case B (Start.Layer) (Start.Row, Start.Column).Piece is
         when Sylph =>
            return Sylph_Increment (C, Start, Move_Number, B);
         when others => raise Program_Error;
      end case;
   end Increment;

   function Next_Move (C: Player_Type; I: Board_Move; B: Board) return
Board_Move is
      J : Board_Move := I;
   begin
      loop
         J := Increment (C, J, B);

         if not (B (J.End_Loc.Layer) (J.End_Loc.Row, J.End_Loc.Column).Exists
and then
                 B (J.End_Loc.Layer) (J.End_Loc.Row, J.End_Loc.Column).Player =
C)
         then
            return J;
         end if;

      end loop;
   end Next_Move;

end Iterate_Moves;
with Board_Types; use Board_Types;

package Iterate_Moves is

   pragma Pure (Iterate_Moves);

   type Board_Move is private;
   function Next_Move (C: Player_Type; I: Board_Move; B: Board) return
Board_Move;

   No_Next_Move: exception;

private

   type Board_Move_Type is (Forged, Initial, Increment, True_Move);

   type Board_Move is record
      Start_Loc : Board_Location;
      End_Loc : Board_Location;
      Move_Type : Board_Move_Type;
      Move_Number : Natural;
   end record;

end Iterate_Moves;
separate (Iterate_Moves)
function Next_Piece (C: Player_Type; Piece: Board_Location; B : Board)
                    return Board_Location
is
   pragma Suppress (All_Checks);
   S : Board_Location := Piece;
begin
   while (S.Column /= Column_Type'Last) loop
      S.Column := S.Column + 1;
      if B (S.Layer) (S.Row, S.Column).Exists and then
        B (S.Layer) (S.Row, S.Column).Player = C
      then
         return S;
      end if;
   end loop;
   loop
      if S.Row = Row_Type'Last then
         if S.Layer = Lower then
            raise No_Next_Move;
         elsif S.Layer = Middle then
            S := (Lower, 1, 1);
         else
            S := (Middle, 1, 1);
         end if;
      else
         S.Row := S.Row + 1;
         S.Column := 1;
      end if;
      for Column in Column_Type'Range loop
         if B (S.Layer) (S.Row, Column).Exists and then
           B (S.Layer) (S.Row, Column).Player = C
         then
            S.Column := Column;
            return S;
         end if;
      end loop;
   end loop;
end Next_Piece;


-- 
           Summary: -O3 -gnatVa triggers a bug box on working Dragonchess
                    code
           Product: gcc
           Version: 4.1.2
            Status: UNCONFIRMED
          Severity: normal
          Priority: P3
         Component: ada
        AssignedTo: unassigned at gcc dot gnu dot org
        ReportedBy: prosfilaes at gmail dot com
 GCC build triplet: x86_64-pc-linux-gnu
  GCC host triplet: x86_64-pc-linux-gnu
GCC target triplet: x86_64-pc-linux-gnu


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=29781