Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/support/fdd2a00.a @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 -- FDD2A00.A | |
2 -- | |
3 -- Grant of Unlimited Rights | |
4 -- | |
5 -- The Ada Conformity Assessment Authority (ACAA) holds unlimited | |
6 -- rights in the software and documentation contained herein. Unlimited | |
7 -- rights are the same as those granted by the U.S. Government for older | |
8 -- parts of the Ada Conformity Assessment Test Suite, and are defined | |
9 -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA | |
10 -- intends to confer upon all recipients unlimited rights equal to those | |
11 -- held by the ACAA. These rights include rights to use, duplicate, | |
12 -- release or disclose the released technical data and computer software | |
13 -- in whole or in part, in any manner and for any purpose whatsoever, and | |
14 -- to have or permit others to do so. | |
15 -- | |
16 -- DISCLAIMER | |
17 -- | |
18 -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR | |
19 -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED | |
20 -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE | |
21 -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE | |
22 -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A | |
23 -- PARTICULAR PURPOSE OF SAID MATERIAL. | |
24 -- | |
25 -- | |
26 -- FOUNDATION DESCRIPTION: | |
27 -- This foundation provides the basis for testing user-defined stream | |
28 -- attributes. It provides operations which count calls to stream | |
29 -- attributes. | |
30 -- | |
31 -- CHANGE HISTORY: | |
32 -- 30 JUL 2001 PHL Initial version. | |
33 -- 5 DEC 2001 RLB Reformatted for ACATS. | |
34 -- | |
35 | |
36 with Ada.Streams; | |
37 use Ada.Streams; | |
38 package FDD2A00 is | |
39 | |
40 type Kinds is (Read, Write, Input, Output); | |
41 type Counts is array (Kinds) of Natural; | |
42 | |
43 | |
44 type My_Stream (Size : Stream_Element_Count) is new Root_Stream_Type with | |
45 record | |
46 First : Stream_Element_Offset := 1; | |
47 Last : Stream_Element_Offset := 0; | |
48 Contents : Stream_Element_Array (1 .. Size); | |
49 end record; | |
50 | |
51 procedure Clear (Stream : in out My_Stream); | |
52 | |
53 procedure Read (Stream : in out My_Stream; | |
54 Item : out Stream_Element_Array; | |
55 Last : out Stream_Element_Offset); | |
56 | |
57 procedure Write (Stream : in out My_Stream; Item : in Stream_Element_Array); | |
58 | |
59 | |
60 generic | |
61 type T (<>) is limited private; | |
62 with procedure Actual_Write | |
63 (Stream : access Root_Stream_Type'Class; Item : T); | |
64 with function Actual_Input | |
65 (Stream : access Root_Stream_Type'Class) return T; | |
66 with procedure Actual_Read (Stream : access Root_Stream_Type'Class; | |
67 Item : out T); | |
68 with procedure Actual_Output | |
69 (Stream : access Root_Stream_Type'Class; Item : T); | |
70 package Counting_Stream_Ops is | |
71 | |
72 procedure Write (Stream : access Root_Stream_Type'Class; Item : T); | |
73 function Input (Stream : access Root_Stream_Type'Class) return T; | |
74 procedure Read (Stream : access Root_Stream_Type'Class; Item : out T); | |
75 procedure Output (Stream : access Root_Stream_Type'Class; Item : T); | |
76 | |
77 function Get_Counts return Counts; | |
78 | |
79 end Counting_Stream_Ops; | |
80 | |
81 end FDD2A00; | |
82 package body FDD2A00 is | |
83 | |
84 procedure Clear (Stream : in out My_Stream) is | |
85 begin | |
86 Stream.First := 1; | |
87 Stream.Last := 0; | |
88 end Clear; | |
89 | |
90 procedure Read (Stream : in out My_Stream; | |
91 Item : out Stream_Element_Array; | |
92 Last : out Stream_Element_Offset) is | |
93 begin | |
94 if Item'Length >= Stream.Last - Stream.First + 1 then | |
95 Item (Item'First .. Item'First + Stream.Last - Stream.First) := | |
96 Stream.Contents (Stream.First .. Stream.Last); | |
97 Last := Item'First + Stream.Last - Stream.First; | |
98 Stream.First := Stream.Last + 1; | |
99 else | |
100 Item := Stream.Contents (Stream.First .. | |
101 Stream.First + Item'Length - 1); | |
102 Last := Item'Last; | |
103 Stream.First := Stream.First + Item'Length; | |
104 end if; | |
105 end Read; | |
106 | |
107 procedure Write (Stream : in out My_Stream; | |
108 Item : in Stream_Element_Array) is | |
109 begin | |
110 Stream.Contents (Stream.Last + 1 .. Stream.Last + Item'Length) := Item; | |
111 Stream.Last := Stream.Last + Item'Length; | |
112 end Write; | |
113 | |
114 | |
115 package body Counting_Stream_Ops is | |
116 Cnts : Counts := (others => 0); | |
117 | |
118 procedure Write (Stream : access Root_Stream_Type'Class; Item : T) is | |
119 begin | |
120 Cnts (Write) := Cnts (Write) + 1; | |
121 Actual_Write (Stream, Item); | |
122 end Write; | |
123 | |
124 function Input (Stream : access Root_Stream_Type'Class) return T is | |
125 begin | |
126 Cnts (Input) := Cnts (Input) + 1; | |
127 return Actual_Input (Stream); | |
128 end Input; | |
129 | |
130 procedure Read (Stream : access Root_Stream_Type'Class; Item : out T) is | |
131 begin | |
132 Cnts (Read) := Cnts (Read) + 1; | |
133 Actual_Read (Stream, Item); | |
134 end Read; | |
135 | |
136 procedure Output (Stream : access Root_Stream_Type'Class; Item : T) is | |
137 begin | |
138 Cnts (Output) := Cnts (Output) + 1; | |
139 Actual_Output (Stream, Item); | |
140 end Output; | |
141 | |
142 function Get_Counts return Counts is | |
143 begin | |
144 return Cnts; | |
145 end Get_Counts; | |
146 | |
147 end Counting_Stream_Ops; | |
148 | |
149 end FDD2A00; |