-- C416A02.A -- -- Grant of Unlimited Rights -- -- The Ada Conformity Assessment Authority (ACAA) holds unlimited -- rights in the software and documentation contained herein. Unlimited -- rights are the same as those granted by the U.S. Government for older -- parts of the Ada Conformity Assessment Test Suite, and are defined -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA -- intends to confer upon all recipients unlimited rights equal to those -- held by the ACAA. These rights include rights to use, duplicate, -- release or disclose the released technical data and computer software -- in whole or in part, in any manner and for any purpose whatsoever, and -- to have or permit others to do so. -- -- DISCLAIMER -- -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR -- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A -- PARTICULAR PURPOSE OF SAID MATERIAL. -- -- Notice -- -- The ACAA has created and maintains the Ada Conformity Assessment Test -- Suite for the purpose of conformity assessments conducted in accordance -- with the International Standard ISO/IEC 18009 - Ada: Conformity -- assessment of a language processor. This test suite should not be used -- to make claims of conformance unless used in accordance with -- ISO/IEC 18009 and any applicable ACAA procedures. -- --* -- OBJECTIVE: -- Check that the name specified for a Constant_Indexing or -- Variable_Indexing aspect can refer to a set of overloaded functions. -- (Case B: overloaded on result types) -- -- Check that if a function used by an inherited Constant_Indexing or -- Variable_Indexing is overloaded (with a different profile), the -- overloaded function can be called by a generalized indexing. -- -- Check that if a function used by an inherited Constant_Indexing or -- Variable_Indexing is overridden, the overridden function is called -- by a generalized indexing. -- -- Check that a generalized indexing can be used for an object of a derived -- type that inherits the Constant_Indexing or Variable_Indexing aspect -- from its parent type. -- -- TEST DESCRIPTION: -- The foundation is a sprite-drawing package. We derive a new type from -- it, adding new and overridden CRef and VRef operations. The main -- subprogram defines several sprites in a window and tests operations -- on them, using both the old and new generalized indexing operations. -- -- CHANGE HISTORY: -- 13 May 2015 RLB Created test. -- 14 May 2015 RLB Added an additional objective (already tested). -- 14 Aug 2015 RLB Changed the package of New_Window to be a child -- so that the parent components are visible in the -- body. -- 30 Sep 2015 RLB Corrected "sC" item to use the Kind VRef. package F416A00.C416A02_A is type New_Window is new F416A00.Window with private; Missing_Error : exception renames F416A00.Missing_Error; overriding function CRef (W : in New_Window; N : in Name) return Sprite; overriding function VRef (W : aliased in out New_Window; N : in Name) return F416A00.Ref_Rec; not overriding function CRef (W : in New_Window; N : in Name) return Kind; type K_Ref_Rec (D : access Kind) is null record with Implicit_Dereference => D; not overriding function VRef (W : aliased in out New_Window; N : in Name) return K_Ref_Rec; -- inherits the following: --function CRef (W : in New_Window; X, Y : in Natural) return Sprite; -- --function VRef (W : aliased in out New_Window; X, Y : in Natural) -- return F416A00.Ref_Rec; private type New_Window is new F416A00.Window with null record; end F416A00.C416A02_A; with TcTouch; package body F416A00.C416A02_A is function CRef (W : in New_Window; N : in Name) return Sprite is begin TcTouch.Touch('b'); TcTouch.Touch(N(1)); --------------- for I in 1 .. W.Count loop if W.Sprites(I).N = N then return W.Sprites(I).S; end if; end loop; raise Missing_Error; end CRef; function VRef (W : aliased in out New_Window; N : in Name) return F416A00.Ref_Rec is begin TcTouch.Touch('t'); TcTouch.Touch(N(1)); --------------- for I in 1 .. W.Count loop if W.Sprites(I).N = N then return (D => W.Sprites(I).S'Access); end if; end loop; raise Missing_Error; end VRef; function CRef (W : in New_Window; N : in Name) return Kind is begin TcTouch.Touch('a'); TcTouch.Touch(N(1)); --------------- for I in 1 .. W.Count loop if W.Sprites(I).N = N then return W.Sprites(I).S.K; end if; end loop; raise Missing_Error; end CRef; function VRef (W : aliased in out New_Window; N : in Name) return K_Ref_Rec is begin TcTouch.Touch('s'); TcTouch.Touch(N(1)); --------------- for I in 1 .. W.Count loop if W.Sprites(I).N = N then return (D => W.Sprites(I).S.K'Access); end if; end loop; raise Missing_Error; end VRef; end F416A00.C416A02_A; with Report; with F416A00.C416A02_A; use F416A00.C416A02_A; with TcTouch; procedure C416A02 is Maze : New_Window; use all type F416A00.Kind; -- Makes enumeration literals visible. use all type F416A00.Color; -- Makes enumeration literals visible. begin Report.Test ("C416A02", "Check that the overloaded routines can be added to an " & "inherited indexing aspect and the new routines can be " & "used in a generalized indexing"); -- Create sprites: Create_Sprite (Maze, "User ", X=> 10, Y => 10, K => Player, C => Yellow); Create_Sprite (Maze, "Blinky", X=> 1, Y => 1, K => Ghost, C => Red); Create_Sprite (Maze, "Pinky ", X=> 1, Y => 20, K => Ghost, C => Pink); Create_Sprite (Maze, "Inky ", X=> 20, Y => 20, K => Ghost, C => Cyan); Create_Sprite (Maze, "Clyde ", X=> 20, Y => 1, K => Ghost, C => Orange); -- Check some sprite properties by name: (overridden/overloaded CRef(Name)) if Maze("Blinky").C /= Red then ------- bB Report.Failed ("Wrong color (A)"); end if; if Maze("Clyde ") /= Ghost then ------- aC Report.Failed ("Wrong kind (A1)"); end if; if Maze("User ") /= Player then ------- aU Report.Failed ("Wrong kind (A2)"); end if; begin if Maze("Stinky") /= Ghost then ------- aS Report.Comment ("Weird"); end if; Report.Failed ("Exception not raised by unknown name (A)"); exception when Missing_Error => null; -- Expected. end; TcTouch.Validate (Expected => "bBaCaUaS", Message => "Index by name wrong (A)"); -- Check some sprite properties by position: (inherited CRef(X, Y)) if Maze(10, 10).C /= Yellow then ------- dJJ Report.Failed ("Wrong color (B)"); end if; if Maze(20, 20).K /= Ghost then ------- dTT Report.Failed ("Wrong kind (B)"); end if; TcTouch.Validate (Expected => "dJJdTT", Message => "Index by position wrong (B)"); -- Change sprite color/kind by name: (overridden/overloaded VRef(Name)) Maze("Clyde ").C := White; ------- tC Maze("Clyde ") := Power_Pill; ------- sC if Maze("User ") /= Player or else ------- aU Maze("User ").C /= Yellow then ------- bU Report.Failed ("Change by name changed wrong item (C)"); end if; if Maze("Clyde ") /= Power_Pill or else ------- aC Maze("Clyde ").C /= White or else ------- bC Maze("Clyde ").X /= 20 or else ------- bC Maze("Clyde ").Y /= 1 then ------- bC Report.Failed ("Change by name failed (C)"); end if; TcTouch.Validate (Expected => "tCsCaUbUaCbCbCbC", Message => "Modifications wrong (C)"); Report.Result; end C416A02;