home *** CD-ROM | disk | FTP | other *** search
/ Solo Programadores 22 / SOLO_22.iso / packages / win32ada / data.z / win32-search.adb < prev    next >
Encoding:
Text File  |  1995-12-27  |  5.5 KB  |  164 lines
  1. -- $Source: /home/harp/1/proto/monoBANK/winnt/win32-search.adb,v $ 
  2. -- $Revision: 1.6 $ $Date: 95/02/06 12:57:17 $ $Author: mg $ 
  3. -------------------------------------------------------------------------------
  4. --
  5. -- THIS FILE AND ANY ASSOCIATED DOCUMENTATION IS FURNISHED "AS IS" WITHOUT 
  6. -- WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED 
  7. -- TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR 
  8. -- PURPOSE.  The user assumes the entire risk as to the accuracy and the 
  9. -- use of this file.
  10. --
  11. -- Copyright (c) Intermetrics, Inc. 1995
  12. -- Royalty-free, unlimited, worldwide, non-exclusive use, modification, 
  13. -- reproduction and further distribution of this file is permitted.
  14. --
  15. -------------------------------------------------------------------------------
  16.  
  17.  
  18. with Ada.Unchecked_Conversion;
  19. with Interfaces.C;
  20. with System;
  21.  
  22. package body Win32.Search is
  23.  
  24.     type AC_Elem is access constant Elem;
  25.  
  26.     subtype Unsigned is Interfaces.C.Unsigned;
  27.  
  28.     Elem_Size: constant Unsigned := Unsigned(Elem'Size/System.Storage_Unit);
  29.  
  30.     function Compare (Left, Right : AC_Elem) return Integer;
  31.     -- pragma Convention (Stdcall, Compare);
  32.  
  33.     function Compare (Left, Right : AC_Elem) return Integer is
  34.     begin
  35.     if Left.All = Right.all then 
  36.         return 0;
  37.     elsif Left.all < Right.all then
  38.         return -1;
  39.     else
  40.         return 1;
  41.     end if;
  42.     end Compare;
  43.  
  44.     type Compare_Func is access function (Left, Right : AC_Elem) return Integer;
  45.  
  46.     function c_bsearch(key    : AC_Elem;
  47.                        base   : AC_Elem;
  48.                        num    : Unsigned;
  49.                        width  : Unsigned;
  50.                        compare: Compare_Func)
  51.                               return AC_Elem;                
  52.     -- pragma Convention(Stdcall, Compare_Func);
  53.         
  54.     function c_lsearch(key    : AC_Elem;
  55.                        base   : access Elem;
  56.                        num    : access Unsigned;
  57.                        width  : Unsigned;
  58.                        compare: Compare_Func)
  59.                               return AC_Elem;                
  60.  
  61.     function c_lfind(key    : AC_Elem;
  62.                      base   : AC_Elem;
  63.                      num    : access Unsigned;
  64.                      width  : Unsigned;
  65.                      compare: Compare_Func)
  66.                             return AC_Elem;                  
  67.  
  68.     procedure c_qsort(base  : access Elem;
  69.                       num   : Unsigned;
  70.                       width : Unsigned;
  71.                       compar: Compare_Func);                    
  72.  
  73.     pragma Import(C, c_bsearch, "bsearch");                       
  74.     pragma Import(C, c_lsearch, "_lsearch");        -- Windows NT
  75.     pragma Import(C, c_lfind, "_lfind");        -- Windows NT
  76.     -- pragma Import(C, c_lsearch, "lsearch");        -- Sun
  77.     -- pragma Import(C, c_lfind, "lfind");        -- Sun
  78.     pragma Import(C, c_qsort, "qsort");                           
  79.  
  80.     Dummy: Elem;
  81.  
  82.     function "-" (Left, Right: AC_Elem) return Integer is
  83.     -- Interfaces.C.Pointers not working right at the time of writing.
  84.     function To_Int is new Ada.Unchecked_Conversion (AC_Elem, Integer);
  85.     begin
  86.     return (To_Int(Left) - To_Int(Right)) / Integer(Elem_Size);
  87.     end "-";
  88.  
  89.     procedure Bsearch(The_Key   : in Elem;
  90.               The_Array : in Array_of_Elem;
  91.               Result    : out Index) is
  92.     Local_Copy: aliased constant Elem := The_Key;
  93.     Res       : AC_Elem := c_bsearch(
  94.                   Local_Copy'unchecked_access, 
  95.                   The_Array(The_Array'First)'unchecked_access,
  96.                       The_Array'Length, 
  97.                   Elem_Size,
  98.                       Compare'access);
  99.     begin
  100.     if Res = null then     -- assumes Ada and C null are the same
  101.         Result := Not_Found;
  102.     else
  103.         Result := The_Array'First + 
  104.               Index(Res - The_Array(The_Array'First)'unchecked_access);
  105.     end if;
  106.     end Bsearch;
  107.  
  108.     procedure LSearch(The_Key         : in Elem;
  109.               The_Array       : in out Array_of_Elem;
  110.               Last_Valid_Elem : in Index;
  111.               Result          : out Index) is
  112.     Local_Copy: aliased constant Elem := The_Key;
  113.     Res       : AC_Elem;
  114.     Len       : aliased Unsigned := 
  115.             Unsigned(Last_Valid_Elem-The_Array'First+1);
  116.     begin
  117.     if Last_Valid_Elem < The_Array'Last then
  118.         Res := C_Lsearch(Local_Copy'unchecked_access, 
  119.                  The_Array(The_Array'First)'unchecked_access,
  120.                  Len'access, 
  121.                  Elem_Size,
  122.                  Compare'access);
  123.         Result := The_Array'First + 
  124.               Index(Res - The_Array(The_Array'First)'unchecked_access);
  125.     else
  126.         Lfind(The_Key, The_Array, Result);
  127.         if Result = Not_Found then 
  128.         raise Constraint_Error;
  129.         end if;
  130.     end if;
  131.     end Lsearch;
  132.  
  133.  
  134.     procedure Lfind(The_Key   : in Elem;
  135.             The_Array : in Array_of_Elem;
  136.             Result    : out Index) is
  137.  
  138.     Local_Copy: aliased constant Elem := The_Key;
  139.     Len       : aliased Unsigned := The_Array'Length;
  140.     Res       : AC_Elem := c_lfind(
  141.                 Local_Copy'unchecked_access, 
  142.                 The_Array(The_Array'First)'unchecked_access,
  143.                 Len'access, 
  144.                 Elem_Size,
  145.                 Compare'access);
  146.     begin
  147.     if Res = null then     -- assumes Ada and C null are the same
  148.         Result := Not_Found;
  149.     else
  150.         Result := The_Array'First + 
  151.               Index(Res - The_Array(The_Array'First)'unchecked_access);
  152.     end if;
  153.     end Lfind;
  154.  
  155.     procedure Qsort(The_Array : in out Array_of_Elem) is
  156.     begin
  157.     C_Qsort(The_Array(The_Array'First)'access,
  158.         The_Array'Length, 
  159.         Elem_Size,
  160.         Compare'access);
  161.     end Qsort;
  162.  
  163. end Win32.Search;
  164.