1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- I N T E R F A C E S . C -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 2, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- As a special exception, if other files instantiate generics from this -- 23-- unit, or you link this unit with other files to produce an executable, -- 24-- this unit does not by itself cause the resulting executable to be -- 25-- covered by the GNU General Public License. This exception does not -- 26-- however invalidate any other reasons why the executable file might be -- 27-- covered by the GNU Public License. -- 28-- -- 29-- GNAT was originally developed by the GNAT team at New York University. -- 30-- Extensive contributions were provided by Ada Core Technologies Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34package body Interfaces.C is 35 36 ----------------------- 37 -- Is_Nul_Terminated -- 38 ----------------------- 39 40 -- Case of char_array 41 42 function Is_Nul_Terminated (Item : char_array) return Boolean is 43 begin 44 for J in Item'Range loop 45 if Item (J) = nul then 46 return True; 47 end if; 48 end loop; 49 50 return False; 51 end Is_Nul_Terminated; 52 53 -- Case of wchar_array 54 55 function Is_Nul_Terminated (Item : wchar_array) return Boolean is 56 begin 57 for J in Item'Range loop 58 if Item (J) = wide_nul then 59 return True; 60 end if; 61 end loop; 62 63 return False; 64 end Is_Nul_Terminated; 65 66 ------------ 67 -- To_Ada -- 68 ------------ 69 70 -- Convert char to Character 71 72 function To_Ada (Item : char) return Character is 73 begin 74 return Character'Val (char'Pos (Item)); 75 end To_Ada; 76 77 -- Convert char_array to String (function form) 78 79 function To_Ada 80 (Item : char_array; 81 Trim_Nul : Boolean := True) 82 return String 83 is 84 Count : Natural; 85 From : size_t; 86 87 begin 88 if Trim_Nul then 89 From := Item'First; 90 91 loop 92 if From > Item'Last then 93 raise Terminator_Error; 94 elsif Item (From) = nul then 95 exit; 96 else 97 From := From + 1; 98 end if; 99 end loop; 100 101 Count := Natural (From - Item'First); 102 103 else 104 Count := Item'Length; 105 end if; 106 107 declare 108 R : String (1 .. Count); 109 110 begin 111 for J in R'Range loop 112 R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); 113 end loop; 114 115 return R; 116 end; 117 end To_Ada; 118 119 -- Convert char_array to String (procedure form) 120 121 procedure To_Ada 122 (Item : char_array; 123 Target : out String; 124 Count : out Natural; 125 Trim_Nul : Boolean := True) 126 is 127 From : size_t; 128 To : Positive; 129 130 begin 131 if Trim_Nul then 132 From := Item'First; 133 loop 134 if From > Item'Last then 135 raise Terminator_Error; 136 elsif Item (From) = nul then 137 exit; 138 else 139 From := From + 1; 140 end if; 141 end loop; 142 143 Count := Natural (From - Item'First); 144 145 else 146 Count := Item'Length; 147 end if; 148 149 if Count > Target'Length then 150 raise Constraint_Error; 151 152 else 153 From := Item'First; 154 To := Target'First; 155 156 for J in 1 .. Count loop 157 Target (To) := Character (Item (From)); 158 From := From + 1; 159 To := To + 1; 160 end loop; 161 end if; 162 163 end To_Ada; 164 165 -- Convert wchar_t to Wide_Character 166 167 function To_Ada (Item : wchar_t) return Wide_Character is 168 begin 169 return Wide_Character (Item); 170 end To_Ada; 171 172 -- Convert wchar_array to Wide_String (function form) 173 174 function To_Ada 175 (Item : wchar_array; 176 Trim_Nul : Boolean := True) 177 return Wide_String 178 is 179 Count : Natural; 180 From : size_t; 181 182 begin 183 if Trim_Nul then 184 From := Item'First; 185 186 loop 187 if From > Item'Last then 188 raise Terminator_Error; 189 elsif Item (From) = wide_nul then 190 exit; 191 else 192 From := From + 1; 193 end if; 194 end loop; 195 196 Count := Natural (From - Item'First); 197 198 else 199 Count := Item'Length; 200 end if; 201 202 declare 203 R : Wide_String (1 .. Count); 204 205 begin 206 for J in R'Range loop 207 R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); 208 end loop; 209 210 return R; 211 end; 212 end To_Ada; 213 214 -- Convert wchar_array to Wide_String (procedure form) 215 216 procedure To_Ada 217 (Item : wchar_array; 218 Target : out Wide_String; 219 Count : out Natural; 220 Trim_Nul : Boolean := True) 221 is 222 From : size_t; 223 To : Positive; 224 225 begin 226 if Trim_Nul then 227 From := Item'First; 228 loop 229 if From > Item'Last then 230 raise Terminator_Error; 231 elsif Item (From) = wide_nul then 232 exit; 233 else 234 From := From + 1; 235 end if; 236 end loop; 237 238 Count := Natural (From - Item'First); 239 240 else 241 Count := Item'Length; 242 end if; 243 244 if Count > Target'Length then 245 raise Constraint_Error; 246 247 else 248 From := Item'First; 249 To := Target'First; 250 251 for J in 1 .. Count loop 252 Target (To) := To_Ada (Item (From)); 253 From := From + 1; 254 To := To + 1; 255 end loop; 256 end if; 257 258 end To_Ada; 259 260 ---------- 261 -- To_C -- 262 ---------- 263 264 -- Convert Character to char 265 266 function To_C (Item : Character) return char is 267 begin 268 return char'Val (Character'Pos (Item)); 269 end To_C; 270 271 -- Convert String to char_array (function form) 272 273 function To_C 274 (Item : String; 275 Append_Nul : Boolean := True) 276 return char_array 277 is 278 begin 279 if Append_Nul then 280 declare 281 R : char_array (0 .. Item'Length); 282 283 begin 284 for J in Item'Range loop 285 R (size_t (J - Item'First)) := To_C (Item (J)); 286 end loop; 287 288 R (R'Last) := nul; 289 return R; 290 end; 291 292 else -- Append_Nul is False 293 294 -- A nasty case, if the string is null, we must return 295 -- a null char_array. The lower bound of this array is 296 -- required to be zero (RM B.3(50)) but that is of course 297 -- impossible given that size_t is unsigned. This needs 298 -- ARG resolution, but for now GNAT returns bounds 1 .. 0 299 300 if Item'Length = 0 then 301 declare 302 R : char_array (1 .. 0); 303 304 begin 305 return R; 306 end; 307 308 else 309 declare 310 R : char_array (0 .. Item'Length - 1); 311 312 begin 313 for J in Item'Range loop 314 R (size_t (J - Item'First)) := To_C (Item (J)); 315 end loop; 316 317 return R; 318 end; 319 end if; 320 end if; 321 end To_C; 322 323 -- Convert String to char_array (procedure form) 324 325 procedure To_C 326 (Item : String; 327 Target : out char_array; 328 Count : out size_t; 329 Append_Nul : Boolean := True) 330 is 331 To : size_t; 332 333 begin 334 if Target'Length < Item'Length then 335 raise Constraint_Error; 336 337 else 338 To := Target'First; 339 for From in Item'Range loop 340 Target (To) := char (Item (From)); 341 To := To + 1; 342 end loop; 343 344 if Append_Nul then 345 if To > Target'Last then 346 raise Constraint_Error; 347 else 348 Target (To) := nul; 349 Count := Item'Length + 1; 350 end if; 351 352 else 353 Count := Item'Length; 354 end if; 355 end if; 356 end To_C; 357 358 -- Convert Wide_Character to wchar_t 359 360 function To_C (Item : Wide_Character) return wchar_t is 361 begin 362 return wchar_t (Item); 363 end To_C; 364 365 -- Convert Wide_String to wchar_array (function form) 366 367 function To_C 368 (Item : Wide_String; 369 Append_Nul : Boolean := True) 370 return wchar_array 371 is 372 begin 373 if Append_Nul then 374 declare 375 R : wchar_array (0 .. Item'Length); 376 377 begin 378 for J in Item'Range loop 379 R (size_t (J - Item'First)) := To_C (Item (J)); 380 end loop; 381 382 R (R'Last) := wide_nul; 383 return R; 384 end; 385 386 else 387 -- A nasty case, if the string is null, we must return 388 -- a null char_array. The lower bound of this array is 389 -- required to be zero (RM B.3(50)) but that is of course 390 -- impossible given that size_t is unsigned. This needs 391 -- ARG resolution, but for now GNAT returns bounds 1 .. 0 392 393 if Item'Length = 0 then 394 declare 395 R : wchar_array (1 .. 0); 396 397 begin 398 return R; 399 end; 400 401 else 402 declare 403 R : wchar_array (0 .. Item'Length - 1); 404 405 begin 406 for J in size_t range 0 .. Item'Length - 1 loop 407 R (J) := To_C (Item (Integer (J) + Item'First)); 408 end loop; 409 410 return R; 411 end; 412 end if; 413 end if; 414 end To_C; 415 416 -- Convert Wide_String to wchar_array (procedure form) 417 418 procedure To_C 419 (Item : Wide_String; 420 Target : out wchar_array; 421 Count : out size_t; 422 Append_Nul : Boolean := True) 423 is 424 To : size_t; 425 426 begin 427 if Target'Length < Item'Length then 428 raise Constraint_Error; 429 430 else 431 To := Target'First; 432 for From in Item'Range loop 433 Target (To) := To_C (Item (From)); 434 To := To + 1; 435 end loop; 436 437 if Append_Nul then 438 if To > Target'Last then 439 raise Constraint_Error; 440 else 441 Target (To) := wide_nul; 442 Count := Item'Length + 1; 443 end if; 444 445 else 446 Count := Item'Length; 447 end if; 448 end if; 449 end To_C; 450 451end Interfaces.C; 452