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