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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cb/] [cb20007.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- CB20007.A
2
--
3
--                             Grant of Unlimited Rights
4
--
5
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7
--     unlimited rights in the software and documentation contained herein.
8
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
9
--     this public release, the Government intends to confer upon all
10
--     recipients unlimited rights  equal to those held by the Government.
11
--     These rights include rights to use, duplicate, release or disclose the
12
--     released technical data and computer software in whole or in part, in
13
--     any manner and for any purpose whatsoever, and to have or permit others
14
--     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
-- OBJECTIVE:
27
--      Check that exceptions are raised and can be directly propagated to
28
--      the calling unit by protected operations.
29
--
30
-- TEST DESCRIPTION:
31
--      Declare a package with a protected type, including protected operation
32
--      declarations and private data, simulating a counting semaphore.
33
--      In the main procedure, perform calls on protected operations
34
--      of the protected object designed to induce the raising of exceptions.
35
--
36
--      The exceptions raised are to be propagated directly from the protected
37
--      operations to the calling unit.
38
--
39
--      Ensure that the exceptions are raised and correctly propagated directly
40
--      to the calling unit from protected procedures and functions.
41
--
42
--
43
-- CHANGE HISTORY:
44
--      06 Dec 94   SAIC    ACVC 2.0
45
--
46
--!
47
 
48
package CB20007_0 is               -- Package Semaphore.
49
 
50
   Handled_In_Function_Caller,
51
   Handled_In_Procedure_Caller : Boolean := False;
52
 
53
   Resource_Overflow,
54
   Resource_Underflow          : exception;
55
 
56
   protected type Counting_Semaphore (Max_Resources : Integer) is
57
      procedure Secure;
58
      function  Resource_Limit_Exceeded return Boolean;
59
      procedure Release;
60
   private
61
      Count : Integer := Max_Resources;
62
   end Counting_Semaphore;
63
 
64
end CB20007_0;
65
 
66
     --=================================================================--
67
 
68
with Report;
69
 
70
package body CB20007_0 is                  -- Package Semaphore.
71
 
72
   protected body Counting_Semaphore is
73
 
74
      procedure Secure is
75
      begin
76
         if (Count = 0) then               -- No resources left to secure.
77
            raise Resource_Underflow;
78
            Report.Failed ("Program control not transferred by raise");
79
         else
80
            Count := Count - 1;            -- Available resources decremented.
81
         end if;
82
         -- No exception handlers here, direct propagation to calling unit.
83
      end Secure;
84
 
85
 
86
      function Resource_Limit_Exceeded return Boolean is
87
      begin
88
         if (Count > Max_Resources) then
89
            raise Resource_Overflow;       -- Exception used as control flow
90
                                           -- mechanism.
91
            Report.Failed ("Program control not transferred by raise");
92
         else
93
            return (False);
94
         end if;
95
         -- No exception handlers here, direct propagation to calling unit.
96
      end Resource_Limit_Exceeded;
97
 
98
 
99
      procedure Release is
100
      begin
101
         Count := Count + 1;               -- Count of resources available
102
                                           -- incremented.
103
         if Resource_Limit_Exceeded then   -- Call to protected operation
104
            Count := Count - 1;            -- function that raises an
105
                                           -- exception.
106
            Report.Failed("Resource limit exceeded");
107
         end if;
108
         -- No exception handler here for exception raised in function.
109
         -- Exception will propagate directly to calling unit.
110
      end Release;
111
 
112
 
113
   end Counting_Semaphore;
114
 
115
end CB20007_0;
116
 
117
 
118
     --=================================================================--
119
 
120
 
121
with CB20007_0;                           -- Package Semaphore.
122
with Report;
123
 
124
procedure CB20007 is
125
begin
126
 
127
   Test_Block:
128
   declare
129
 
130
      package Semaphore renames CB20007_0;
131
 
132
      Total_Resources_Available : constant := 1;
133
 
134
      Resources : Semaphore.Counting_Semaphore (Total_Resources_Available);
135
                                             -- An object of protected type.
136
 
137
   begin
138
 
139
      Report.Test ("CB20007", "Check that exceptions are raised and can "   &
140
                              "be directly propagated to the calling unit " &
141
                              "by protected operations" );
142
 
143
      Allocate_Resources:
144
      declare
145
         Loop_Count : Integer := Total_Resources_Available + 1;
146
      begin                                   -- Force exception.
147
         for I in 1..Loop_Count loop
148
            Resources.Secure;
149
         end loop;
150
         Report.Failed ("Exception not propagated from protected " &
151
                        " operation in Allocate_Resources");
152
      exception
153
         when Semaphore.Resource_Underflow =>              -- Exception prop.
154
            Semaphore.Handled_In_Procedure_Caller := True; -- from protected
155
                                                           -- procedure.
156
         when others =>
157
            Report.Failed ("Unknown exception during resource allocation");
158
      end Allocate_Resources;
159
 
160
 
161
      Deallocate_Resources:
162
      declare
163
         Loop_Count : Integer := Total_Resources_Available + 1;
164
      begin                                   -- Force exception.
165
         for I in 1..Loop_Count loop
166
            Resources.Release;
167
         end loop;
168
         Report.Failed ("Exception not propagated from protected " &
169
                        "operation in Deallocate_Resources");
170
      exception
171
         when Semaphore.Resource_Overflow =>              -- Exception prop
172
            Semaphore.Handled_In_Function_Caller := True; -- from protected
173
                                                          -- function.
174
         when others =>
175
            Report.Failed ("Exception raised during resource deallocation");
176
      end Deallocate_Resources;
177
 
178
 
179
      if not (Semaphore.Handled_In_Procedure_Caller and -- Incorrect exception
180
              Semaphore.Handled_In_Function_Caller)     -- handling in
181
      then                                              -- protected ops.
182
          Report.Failed
183
            ("Improper exception propagation by protected operations");
184
      end if;
185
 
186
   exception
187
 
188
      when others =>
189
         Report.Failed ("Unexpected exception " &
190
                        " raised and propagated in test");
191
   end Test_Block;
192
 
193
 
194
   Report.Result;
195
 
196
end CB20007;

powered by: WebSVN 2.1.0

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