llvm-gcc-4.2/gcc/testsuite/ada/acats/support/fb20a00.a

-- FB20A00.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     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 GOVERNMENT 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.
--*
--
-- FOUNDATION DESCRIPTION:
--      This test performs a search for the first instance of a specified 
--      substring within a specified string, returning boolean result.
--      (Case insensitive analysis)  Both the string and the substring are 
--      made upper case.  Successive slices are taken from the input string
--      and compared with the substring. If a match is found, the search is 
--      terminated immediately. The search continues until the last index 
--      position from which a substring-length slice can be constructed is
--      passed. 
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!

package FB20A00 is

   function Find ( Str : in String ;           
                   Sub : in String ) return Boolean;

end FB20A00;

     --=================================================================--

package body FB20A00 is
                 
   function Find ( Str : in String ;          
                   Sub : in String ) return Boolean is

      New_Str : String (Str'First .. Str'Last);
      New_Sub : String (Sub'First .. Sub'Last);

      Pos : Integer := Str'First ;             -- Character index.

                 
      function Upper_Case (Str : in String) return String is
         subtype Upper is Character range 'A' .. 'Z' ;
         subtype Lower is Character range 'a' .. 'z' ;
         Ret : String (Str'First .. Str'Last) ;
         Pos : Integer;
      begin
         for I in Str'Range loop
            if ( Str (I) in Lower ) then
               Pos := Upper'Pos (Upper'First) +
                      ( Lower'Pos (Str(I)) - Lower'Pos(Lower'First) ) ;
               Ret (I) := Upper'Val (Pos) ;
            else
               Ret (I) := Str (I);
            end if ;
         end loop ;
         return (Ret) ;
      end Upper_Case;

   begin

      
      New_Str := Upper_Case (Str);             -- Convert Str and Sub to upper 
      New_Sub := Upper_Case (Sub);             -- case for comparison.

      while ( Pos <= New_Str'Last-New_Sub'Length+1 )  -- Search until no more 
        and then                                      -- sub-string-length 
        ( New_Str ( Pos .. Pos+New_Sub'Length-1 ) /= New_Sub ) -- slices
                                                               -- remain.
      loop
         Pos := Pos + 1 ;
      end loop ;

      if ( Pos > New_Str'Last-New_Sub'Length+1 ) then  -- Substring not found.
         return (False);
      else
         return (True);
      end if ;

   end Find;

end FB20A00;