home *** CD-ROM | disk | FTP | other *** search
/ Solo Programadores 22 / SOLO_22.iso / packages / win32ada / data.z / win32.adb < prev    next >
Encoding:
Text File  |  1995-12-27  |  6.6 KB  |  204 lines
  1. -- $Source: /home/harp/1/proto/monoBANK/winnt/win32.adb,v $ 
  2. -- $Revision: 1.12 $ $Date: 95/12/15 17:05:28 $ $Author: mg $ 
  3.  
  4. with Ada.Unchecked_Conversion;
  5. with System;
  6.  
  7. package body Win32 is
  8.  
  9.     function Cat (Left, Right: String) return String is
  10.         Nul: constant Character := Character'First;
  11.     begin
  12.     if Left(Left'Last) = Nul then
  13.         if Right(Right'Last) = Nul then
  14.         return Left(Left'First..Left'last-1) & Right;
  15.         else
  16.         return Left(Left'First..Left'last-1) & Right & Nul;
  17.         end if;
  18.     else
  19.         if Right(Right'Last) = Nul then
  20.         return Left & Right;
  21.         else
  22.         return Left & Right & Nul;
  23.         end if;
  24.     end if;
  25.     end Cat;
  26.  
  27.     function Cat (Left, Right: Wide_String) return Wide_String is
  28.         Nul: constant Wide_Character := Wide_Character'First;
  29.     begin
  30.     if Left(Left'Last) = Nul then
  31.         if Right(Right'Last) = Nul then
  32.         return Left(Left'First..Left'last-1) & Right;
  33.         else
  34.         return Left(Left'First..Left'last-1) & Right & Nul;
  35.         end if;
  36.     else
  37.         if Right(Right'Last) = Nul then
  38.         return Left & Right;
  39.         else
  40.         return Left & Right & Nul;
  41.         end if;
  42.     end if;
  43.     end Cat;
  44.  
  45.     function Cat (Left, Right: CHAR_Array) return CHAR_Array is
  46.         Nul: constant CHAR := CHAR'First;
  47.     use type Win32.CHAR;
  48.     begin
  49.         if Left(Left'Last) = Nul then
  50.             if Right(Right'Last) = Nul then
  51.                 return Left(Left'First..Left'last-1) & Right;
  52.             else
  53.                 return Left(Left'First..Left'last-1) & Right & Nul;
  54.             end if;
  55.         else
  56.             if Right(Right'Last) = Nul then
  57.                 return Left & Right;
  58.             else
  59.                 return Left & Right & Nul;
  60.             end if;
  61.         end if;
  62.     end Cat;
  63.  
  64.     function Cat (Left, Right: WCHAR_Array) return WCHAR_Array is
  65.         Nul: constant WCHAR := WCHAR'First;
  66.     use type Win32.WCHAR;
  67.     begin
  68.         if Left(Left'Last) = Nul then
  69.             if Right(Right'Last) = Nul then
  70.                 return Left(Left'First..Left'last-1) & Right;
  71.             else
  72.                 return Left(Left'First..Left'last-1) & Right & Nul;
  73.             end if;
  74.         else
  75.             if Right(Right'Last) = Nul then
  76.                 return Left & Right;
  77.             else
  78.                 return Left & Right & Nul;
  79.             end if;
  80.         end if;
  81.     end Cat;
  82.  
  83.     function Addr(S: String) return PSTR is
  84.         function To_PSTR is new Ada.Unchecked_Conversion (
  85.                                     System.Address, PSTR);
  86.     begin
  87.         return To_PSTR(S(S'First)'Address);
  88.     end Addr;
  89.  
  90.     function Addr(S: String) return PCSTR is
  91.         function To_PCSTR is new Ada.Unchecked_Conversion (
  92.                                      System.Address, PCSTR);
  93.     begin
  94.         return To_PCSTR(S(S'First)'Address);
  95.     end Addr;
  96.  
  97.     function Addr (S: Wide_String) return PWSTR is
  98.         function To_PWSTR is new Ada.Unchecked_Conversion (
  99.                                      System.Address, PWSTR);
  100.     begin
  101.         return To_PWSTR(S(S'First)'Address);
  102.     end Addr;
  103.  
  104.     function Addr (S: Wide_String) return PCWSTR is
  105.         function To_PCWSTR is new Ada.Unchecked_Conversion (
  106.                                       System.Address, PCWSTR);
  107.     begin
  108.         return To_PCWSTR(S(S'First)'Address);
  109.     end Addr;
  110.  
  111.     function Addr(S: CHAR_Array) return PSTR is
  112.         function To_PSTR is new Ada.Unchecked_Conversion (
  113.                                     System.Address, PSTR);
  114.     begin
  115.         return To_PSTR(S(S'First)'Address);
  116.     end Addr;
  117.  
  118.     function Addr(S: CHAR_Array) return PCSTR is
  119.         function To_PCSTR is new Ada.Unchecked_Conversion (
  120.                                      System.Address, PCSTR);
  121.     begin
  122.         return To_PCSTR(S(S'First)'Address);
  123.     end Addr;
  124.  
  125.     function Addr (S: WCHAR_Array) return PWSTR is
  126.         function To_PWSTR is new Ada.Unchecked_Conversion (
  127.                                      System.Address, PWSTR);
  128.     begin
  129.         return To_PWSTR(S(S'First)'Address);
  130.     end Addr;
  131.  
  132.     function Addr (S: WCHAR_Array) return PCWSTR is
  133.         function To_PCWSTR is new Ada.Unchecked_Conversion (
  134.                                       System.Address, PCWSTR);
  135.     begin
  136.         return To_PCWSTR(S(S'First)'Address);
  137.     end Addr;
  138.  
  139.     function To_Chars_Ptr (STR: PSTR) return Interfaces.C.Strings.Chars_Ptr is
  140.         function UC1 is new Ada.Unchecked_Conversion (
  141.                                 PSTR, Interfaces.C.Strings.Chars_Ptr);
  142.     begin
  143.         return UC1(STR);
  144.     end To_Chars_Ptr;
  145.  
  146.     function To_Chars_Ptr (STR: PCSTR) return Interfaces.C.Strings.Chars_Ptr is
  147.         function UC2 is new Ada.Unchecked_Conversion (
  148.                                 PCSTR, Interfaces.C.Strings.Chars_Ptr);
  149.     begin
  150.         return UC2(STR);
  151.     end To_Chars_Ptr;
  152.  
  153.     function To_PSTR (CP: Interfaces.C.Strings.Chars_Ptr) return PSTR is
  154.         function UC3 is new Ada.Unchecked_Conversion (
  155.                                 Interfaces.C.Strings.Chars_Ptr, PSTR);
  156.     begin
  157.         return UC3(CP);
  158.     end To_PSTR;
  159.  
  160.     function To_PCSTR (CP: Interfaces.C.Strings.Chars_Ptr) return PCSTR is
  161.         function UC4 is new Ada.Unchecked_Conversion (
  162.                                 Interfaces.C.Strings.Chars_Ptr, PCSTR);
  163.     begin
  164.         return UC4(CP);
  165.     end To_PCSTR;
  166.  
  167.     function To_C (S: CHAR_Array) return Interfaces.C.CHAR_Array is
  168.     Res: Interfaces.C.CHAR_Array(
  169.          Interfaces.C.Size_t(S'First) ..
  170.          Interfaces.C.Size_t(S'Last));
  171.     begin
  172.     Res := Interfaces.C.CHAR_Array(S);
  173.     return Res;
  174.     end To_C;
  175.  
  176.     function To_Win (S: Interfaces.C.CHAR_Array) return CHAR_Array is
  177.     Low  : Integer := Integer(S'First);
  178.     High : Integer := Integer(S'Last);
  179.     Res  : CHAR_Array(Low..High);
  180.     use type Interfaces.C.Size_t;    -- to get "+"
  181.     begin
  182.     -- Res := CHAR_Array(S);    -- Gnat 3.01 crash
  183.     for I in S'Range loop
  184.         Res(Res'First + Natural(I - S'First)) := S(I);
  185.     end loop;
  186.     return Res;
  187.     end To_Win;
  188.  
  189. -------------------------------------------------------------------------------
  190. --
  191. -- THIS FILE AND ANY ASSOCIATED DOCUMENTATION IS FURNISHED "AS IS" WITHOUT 
  192. -- WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED 
  193. -- TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR 
  194. -- PURPOSE.  The user assumes the entire risk as to the accuracy and the 
  195. -- use of this file.
  196. --
  197. -- Copyright (c) Intermetrics, Inc. 1995
  198. -- Royalty-free, unlimited, worldwide, non-exclusive use, modification, 
  199. -- reproduction and further distribution of this file is permitted.
  200. --
  201. -------------------------------------------------------------------------------
  202.  
  203. end Win32;              
  204.