OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-stratt.adb] - Blame information for rev 801

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
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
 
32
with Ada.IO_Exceptions;
33
with Ada.Streams; use Ada.Streams;
34
with Ada.Unchecked_Conversion;
35
 
36
package 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
 
708
end System.Stream_Attributes;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.