1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUNTIME COMPONENTS -- 4-- -- 5-- S Y S T E M . S T R E A M _ A T T R I B U T E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2003, 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 34with Ada.IO_Exceptions; 35with Ada.Streams; use Ada.Streams; 36with Unchecked_Conversion; 37 38package body System.Stream_Attributes is 39 40 Err : exception renames Ada.IO_Exceptions.End_Error; 41 -- Exception raised if insufficient data read (note that the RM implies 42 -- that Data_Error might be the appropriate choice, but AI195-00132 43 -- decides with a binding interpretation that End_Error is preferred). 44 45 SU : constant := System.Storage_Unit; 46 47 subtype SEA is Ada.Streams.Stream_Element_Array; 48 subtype SEO is Ada.Streams.Stream_Element_Offset; 49 50 generic function UC renames Unchecked_Conversion; 51 52 -- Subtypes used to define Stream_Element_Array values that map 53 -- into the elementary types, using unchecked conversion. 54 55 Thin_Pointer_Size : constant := System.Address'Size; 56 Fat_Pointer_Size : constant := System.Address'Size * 2; 57 58 subtype S_AD is SEA (1 .. (Fat_Pointer_Size + SU - 1) / SU); 59 subtype S_AS is SEA (1 .. (Thin_Pointer_Size + SU - 1) / SU); 60 subtype S_B is SEA (1 .. (Boolean'Size + SU - 1) / SU); 61 subtype S_C is SEA (1 .. (Character'Size + SU - 1) / SU); 62 subtype S_F is SEA (1 .. (Float'Size + SU - 1) / SU); 63 subtype S_I is SEA (1 .. (Integer'Size + SU - 1) / SU); 64 subtype S_LF is SEA (1 .. (Long_Float'Size + SU - 1) / SU); 65 subtype S_LI is SEA (1 .. (Long_Integer'Size + SU - 1) / SU); 66 subtype S_LLF is SEA (1 .. (Long_Long_Float'Size + SU - 1) / SU); 67 subtype S_LLI is SEA (1 .. (Long_Long_Integer'Size + SU - 1) / SU); 68 subtype S_LLU is SEA (1 .. (UST.Long_Long_Unsigned'Size + SU - 1) / SU); 69 subtype S_LU is SEA (1 .. (UST.Long_Unsigned'Size + SU - 1) / SU); 70 subtype S_SF is SEA (1 .. (Short_Float'Size + SU - 1) / SU); 71 subtype S_SI is SEA (1 .. (Short_Integer'Size + SU - 1) / SU); 72 subtype S_SSI is SEA (1 .. (Short_Short_Integer'Size + SU - 1) / SU); 73 subtype S_SSU is SEA (1 .. (UST.Short_Short_Unsigned'Size + SU - 1) / SU); 74 subtype S_SU is SEA (1 .. (UST.Short_Unsigned'Size + SU - 1) / SU); 75 subtype S_U is SEA (1 .. (UST.Unsigned'Size + SU - 1) / SU); 76 subtype S_WC is SEA (1 .. (Wide_Character'Size + SU - 1) / SU); 77 78 -- Unchecked conversions from the elementary type to the stream type 79 80 function From_AD is new UC (Fat_Pointer, S_AD); 81 function From_AS is new UC (Thin_Pointer, S_AS); 82 function From_F is new UC (Float, S_F); 83 function From_I is new UC (Integer, S_I); 84 function From_LF is new UC (Long_Float, S_LF); 85 function From_LI is new UC (Long_Integer, S_LI); 86 function From_LLF is new UC (Long_Long_Float, S_LLF); 87 function From_LLI is new UC (Long_Long_Integer, S_LLI); 88 function From_LLU is new UC (UST.Long_Long_Unsigned, S_LLU); 89 function From_LU is new UC (UST.Long_Unsigned, S_LU); 90 function From_SF is new UC (Short_Float, S_SF); 91 function From_SI is new UC (Short_Integer, S_SI); 92 function From_SSI is new UC (Short_Short_Integer, S_SSI); 93 function From_SSU is new UC (UST.Short_Short_Unsigned, S_SSU); 94 function From_SU is new UC (UST.Short_Unsigned, S_SU); 95 function From_U is new UC (UST.Unsigned, S_U); 96 function From_WC is new UC (Wide_Character, S_WC); 97 98 -- Unchecked conversions from the stream type to elementary type 99 100 function To_AD is new UC (S_AD, Fat_Pointer); 101 function To_AS is new UC (S_AS, Thin_Pointer); 102 function To_F is new UC (S_F, Float); 103 function To_I is new UC (S_I, Integer); 104 function To_LF is new UC (S_LF, Long_Float); 105 function To_LI is new UC (S_LI, Long_Integer); 106 function To_LLF is new UC (S_LLF, Long_Long_Float); 107 function To_LLI is new UC (S_LLI, Long_Long_Integer); 108 function To_LLU is new UC (S_LLU, UST.Long_Long_Unsigned); 109 function To_LU is new UC (S_LU, UST.Long_Unsigned); 110 function To_SF is new UC (S_SF, Short_Float); 111 function To_SI is new UC (S_SI, Short_Integer); 112 function To_SSI is new UC (S_SSI, Short_Short_Integer); 113 function To_SSU is new UC (S_SSU, UST.Short_Short_Unsigned); 114 function To_SU is new UC (S_SU, UST.Short_Unsigned); 115 function To_U is new UC (S_U, UST.Unsigned); 116 function To_WC is new UC (S_WC, Wide_Character); 117 118 ---------- 119 -- I_AD -- 120 ---------- 121 122 function I_AD (Stream : access RST) return Fat_Pointer is 123 T : S_AD; 124 L : SEO; 125 126 begin 127 Ada.Streams.Read (Stream.all, T, L); 128 129 if L < T'Last then 130 raise Err; 131 else 132 return To_AD (T); 133 end if; 134 end I_AD; 135 136 ---------- 137 -- I_AS -- 138 ---------- 139 140 function I_AS (Stream : access RST) return Thin_Pointer is 141 T : S_AS; 142 L : SEO; 143 144 begin 145 Ada.Streams.Read (Stream.all, T, L); 146 147 if L < T'Last then 148 raise Err; 149 else 150 return To_AS (T); 151 end if; 152 end I_AS; 153 154 --------- 155 -- I_B -- 156 --------- 157 158 function I_B (Stream : access RST) return Boolean is 159 T : S_B; 160 L : SEO; 161 162 begin 163 Ada.Streams.Read (Stream.all, T, L); 164 165 if L < T'Last then 166 raise Err; 167 else 168 return Boolean'Val (T (1)); 169 end if; 170 end I_B; 171 172 --------- 173 -- I_C -- 174 --------- 175 176 function I_C (Stream : access RST) return Character is 177 T : S_C; 178 L : SEO; 179 180 begin 181 Ada.Streams.Read (Stream.all, T, L); 182 183 if L < T'Last then 184 raise Err; 185 else 186 return Character'Val (T (1)); 187 end if; 188 end I_C; 189 190 --------- 191 -- I_F -- 192 --------- 193 194 function I_F (Stream : access RST) return Float is 195 T : S_F; 196 L : SEO; 197 198 begin 199 Ada.Streams.Read (Stream.all, T, L); 200 201 if L < T'Last then 202 raise Err; 203 else 204 return To_F (T); 205 end if; 206 end I_F; 207 208 --------- 209 -- I_I -- 210 --------- 211 212 function I_I (Stream : access RST) return Integer is 213 T : S_I; 214 L : SEO; 215 216 begin 217 Ada.Streams.Read (Stream.all, T, L); 218 219 if L < T'Last then 220 raise Err; 221 else 222 return To_I (T); 223 end if; 224 end I_I; 225 226 ---------- 227 -- I_LF -- 228 ---------- 229 230 function I_LF (Stream : access RST) return Long_Float is 231 T : S_LF; 232 L : SEO; 233 234 begin 235 Ada.Streams.Read (Stream.all, T, L); 236 237 if L < T'Last then 238 raise Err; 239 else 240 return To_LF (T); 241 end if; 242 end I_LF; 243 244 ---------- 245 -- I_LI -- 246 ---------- 247 248 function I_LI (Stream : access RST) return Long_Integer is 249 T : S_LI; 250 L : SEO; 251 252 begin 253 Ada.Streams.Read (Stream.all, T, L); 254 255 if L < T'Last then 256 raise Err; 257 else 258 return To_LI (T); 259 end if; 260 end I_LI; 261 262 ----------- 263 -- I_LLF -- 264 ----------- 265 266 function I_LLF (Stream : access RST) return Long_Long_Float is 267 T : S_LLF; 268 L : SEO; 269 270 begin 271 Ada.Streams.Read (Stream.all, T, L); 272 273 if L < T'Last then 274 raise Err; 275 else 276 return To_LLF (T); 277 end if; 278 end I_LLF; 279 280 ----------- 281 -- I_LLI -- 282 ----------- 283 284 function I_LLI (Stream : access RST) return Long_Long_Integer is 285 T : S_LLI; 286 L : SEO; 287 288 begin 289 Ada.Streams.Read (Stream.all, T, L); 290 291 if L < T'Last then 292 raise Err; 293 else 294 return To_LLI (T); 295 end if; 296 end I_LLI; 297 298 ----------- 299 -- I_LLU -- 300 ----------- 301 302 function I_LLU (Stream : access RST) return UST.Long_Long_Unsigned is 303 T : S_LLU; 304 L : SEO; 305 306 begin 307 Ada.Streams.Read (Stream.all, T, L); 308 309 if L < T'Last then 310 raise Err; 311 else 312 return To_LLU (T); 313 end if; 314 end I_LLU; 315 316 ---------- 317 -- I_LU -- 318 ---------- 319 320 function I_LU (Stream : access RST) return UST.Long_Unsigned is 321 T : S_LU; 322 L : SEO; 323 324 begin 325 Ada.Streams.Read (Stream.all, T, L); 326 327 if L < T'Last then 328 raise Err; 329 else 330 return To_LU (T); 331 end if; 332 end I_LU; 333 334 ---------- 335 -- I_SF -- 336 ---------- 337 338 function I_SF (Stream : access RST) return Short_Float is 339 T : S_SF; 340 L : SEO; 341 342 begin 343 Ada.Streams.Read (Stream.all, T, L); 344 345 if L < T'Last then 346 raise Err; 347 else 348 return To_SF (T); 349 end if; 350 end I_SF; 351 352 ---------- 353 -- I_SI -- 354 ---------- 355 356 function I_SI (Stream : access RST) return Short_Integer is 357 T : S_SI; 358 L : SEO; 359 360 begin 361 Ada.Streams.Read (Stream.all, T, L); 362 363 if L < T'Last then 364 raise Err; 365 else 366 return To_SI (T); 367 end if; 368 end I_SI; 369 370 ----------- 371 -- I_SSI -- 372 ----------- 373 374 function I_SSI (Stream : access RST) return Short_Short_Integer is 375 T : S_SSI; 376 L : SEO; 377 378 begin 379 Ada.Streams.Read (Stream.all, T, L); 380 381 if L < T'Last then 382 raise Err; 383 else 384 return To_SSI (T); 385 end if; 386 end I_SSI; 387 388 ----------- 389 -- I_SSU -- 390 ----------- 391 392 function I_SSU (Stream : access RST) return UST.Short_Short_Unsigned is 393 T : S_SSU; 394 L : SEO; 395 396 begin 397 Ada.Streams.Read (Stream.all, T, L); 398 399 if L < T'Last then 400 raise Err; 401 else 402 return To_SSU (T); 403 end if; 404 end I_SSU; 405 406 ---------- 407 -- I_SU -- 408 ---------- 409 410 function I_SU (Stream : access RST) return UST.Short_Unsigned is 411 T : S_SU; 412 L : SEO; 413 414 begin 415 Ada.Streams.Read (Stream.all, T, L); 416 417 if L < T'Last then 418 raise Err; 419 else 420 return To_SU (T); 421 end if; 422 end I_SU; 423 424 --------- 425 -- I_U -- 426 --------- 427 428 function I_U (Stream : access RST) return UST.Unsigned is 429 T : S_U; 430 L : SEO; 431 432 begin 433 Ada.Streams.Read (Stream.all, T, L); 434 435 if L < T'Last then 436 raise Err; 437 else 438 return To_U (T); 439 end if; 440 end I_U; 441 442 ---------- 443 -- I_WC -- 444 ---------- 445 446 function I_WC (Stream : access RST) return Wide_Character is 447 T : S_WC; 448 L : SEO; 449 450 begin 451 Ada.Streams.Read (Stream.all, T, L); 452 453 if L < T'Last then 454 raise Err; 455 else 456 return To_WC (T); 457 end if; 458 end I_WC; 459 460 ---------- 461 -- W_AD -- 462 ---------- 463 464 procedure W_AD (Stream : access RST; Item : in Fat_Pointer) is 465 T : constant S_AD := From_AD (Item); 466 467 begin 468 Ada.Streams.Write (Stream.all, T); 469 end W_AD; 470 471 ---------- 472 -- W_AS -- 473 ---------- 474 475 procedure W_AS (Stream : access RST; Item : in Thin_Pointer) is 476 T : constant S_AS := From_AS (Item); 477 478 begin 479 Ada.Streams.Write (Stream.all, T); 480 end W_AS; 481 482 --------- 483 -- W_B -- 484 --------- 485 486 procedure W_B (Stream : access RST; Item : in Boolean) is 487 T : S_B; 488 489 begin 490 T (1) := Boolean'Pos (Item); 491 Ada.Streams.Write (Stream.all, T); 492 end W_B; 493 494 --------- 495 -- W_C -- 496 --------- 497 498 procedure W_C (Stream : access RST; Item : in Character) is 499 T : S_C; 500 501 begin 502 T (1) := Character'Pos (Item); 503 Ada.Streams.Write (Stream.all, T); 504 end W_C; 505 506 --------- 507 -- W_F -- 508 --------- 509 510 procedure W_F (Stream : access RST; Item : in Float) is 511 T : constant S_F := From_F (Item); 512 513 begin 514 Ada.Streams.Write (Stream.all, T); 515 end W_F; 516 517 --------- 518 -- W_I -- 519 --------- 520 521 procedure W_I (Stream : access RST; Item : in Integer) is 522 T : constant S_I := From_I (Item); 523 524 begin 525 Ada.Streams.Write (Stream.all, T); 526 end W_I; 527 528 ---------- 529 -- W_LF -- 530 ---------- 531 532 procedure W_LF (Stream : access RST; Item : in Long_Float) is 533 T : constant S_LF := From_LF (Item); 534 535 begin 536 Ada.Streams.Write (Stream.all, T); 537 end W_LF; 538 539 ---------- 540 -- W_LI -- 541 ---------- 542 543 procedure W_LI (Stream : access RST; Item : in Long_Integer) is 544 T : constant S_LI := From_LI (Item); 545 546 begin 547 Ada.Streams.Write (Stream.all, T); 548 end W_LI; 549 550 ----------- 551 -- W_LLF -- 552 ----------- 553 554 procedure W_LLF (Stream : access RST; Item : in Long_Long_Float) is 555 T : constant S_LLF := From_LLF (Item); 556 557 begin 558 Ada.Streams.Write (Stream.all, T); 559 end W_LLF; 560 561 ----------- 562 -- W_LLI -- 563 ----------- 564 565 procedure W_LLI (Stream : access RST; Item : in Long_Long_Integer) is 566 T : constant S_LLI := From_LLI (Item); 567 568 begin 569 Ada.Streams.Write (Stream.all, T); 570 end W_LLI; 571 572 ----------- 573 -- W_LLU -- 574 ----------- 575 576 procedure W_LLU (Stream : access RST; Item : in UST.Long_Long_Unsigned) is 577 T : constant S_LLU := From_LLU (Item); 578 579 begin 580 Ada.Streams.Write (Stream.all, T); 581 end W_LLU; 582 583 ---------- 584 -- W_LU -- 585 ---------- 586 587 procedure W_LU (Stream : access RST; Item : in UST.Long_Unsigned) is 588 T : constant S_LU := From_LU (Item); 589 590 begin 591 Ada.Streams.Write (Stream.all, T); 592 end W_LU; 593 594 ---------- 595 -- W_SF -- 596 ---------- 597 598 procedure W_SF (Stream : access RST; Item : in Short_Float) is 599 T : constant S_SF := From_SF (Item); 600 601 begin 602 Ada.Streams.Write (Stream.all, T); 603 end W_SF; 604 605 ---------- 606 -- W_SI -- 607 ---------- 608 609 procedure W_SI (Stream : access RST; Item : in Short_Integer) is 610 T : constant S_SI := From_SI (Item); 611 612 begin 613 Ada.Streams.Write (Stream.all, T); 614 end W_SI; 615 616 ----------- 617 -- W_SSI -- 618 ----------- 619 620 procedure W_SSI (Stream : access RST; Item : in Short_Short_Integer) is 621 T : constant S_SSI := From_SSI (Item); 622 623 begin 624 Ada.Streams.Write (Stream.all, T); 625 end W_SSI; 626 627 ----------- 628 -- W_SSU -- 629 ----------- 630 631 procedure W_SSU (Stream : access RST; Item : in UST.Short_Short_Unsigned) is 632 T : constant S_SSU := From_SSU (Item); 633 634 begin 635 Ada.Streams.Write (Stream.all, T); 636 end W_SSU; 637 638 ---------- 639 -- W_SU -- 640 ---------- 641 642 procedure W_SU (Stream : access RST; Item : in UST.Short_Unsigned) is 643 T : constant S_SU := From_SU (Item); 644 645 begin 646 Ada.Streams.Write (Stream.all, T); 647 end W_SU; 648 649 --------- 650 -- W_U -- 651 --------- 652 653 procedure W_U (Stream : access RST; Item : in UST.Unsigned) is 654 T : constant S_U := From_U (Item); 655 656 begin 657 Ada.Streams.Write (Stream.all, T); 658 end W_U; 659 660 ---------- 661 -- W_WC -- 662 ---------- 663 664 procedure W_WC (Stream : access RST; Item : in Wide_Character) is 665 T : constant S_WC := From_WC (Item); 666 667 begin 668 Ada.Streams.Write (Stream.all, T); 669 end W_WC; 670 671end System.Stream_Attributes; 672