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