|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- A D A . E X C E P T I O N S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
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 pragma Style_Checks (All_Checks);
|
|
|
33 -- No subprogram ordering check, due to logical grouping
|
|
|
34
|
|
|
35 pragma Polling (Off);
|
|
|
36 -- We must turn polling off for this unit, because otherwise we get
|
|
|
37 -- elaboration circularities with System.Exception_Tables.
|
|
|
38
|
|
|
39 with System; use System;
|
|
|
40 with System.Exceptions; use System.Exceptions;
|
|
|
41 with System.Exceptions_Debug; use System.Exceptions_Debug;
|
|
|
42 with System.Standard_Library; use System.Standard_Library;
|
|
|
43 with System.Soft_Links; use System.Soft_Links;
|
|
|
44 with System.WCh_Con; use System.WCh_Con;
|
|
|
45 with System.WCh_StW; use System.WCh_StW;
|
|
|
46
|
|
|
47 pragma Warnings (Off);
|
|
|
48 -- Suppress complaints about Symbolic not being referenced, and about it not
|
|
|
49 -- having pragma Preelaborate.
|
|
|
50 with System.Traceback.Symbolic;
|
|
|
51 -- Bring Symbolic into the closure. If it is the s-trasym-dwarf.adb version,
|
|
|
52 -- it will install symbolic tracebacks as the default decorator. Otherwise,
|
|
|
53 -- symbolic tracebacks are not supported, and we fall back to hexadecimal
|
|
|
54 -- addresses.
|
|
|
55 pragma Warnings (On);
|
|
|
56
|
|
|
57 package body Ada.Exceptions is
|
|
|
58
|
|
|
59 pragma Suppress (All_Checks);
|
|
|
60 -- We definitely do not want exceptions occurring within this unit, or
|
|
|
61 -- we are in big trouble. If an exceptional situation does occur, better
|
|
|
62 -- that it not be raised, since raising it can cause confusing chaos.
|
|
|
63
|
|
|
64 -----------------------
|
|
|
65 -- Local Subprograms --
|
|
|
66 -----------------------
|
|
|
67
|
|
|
68 -- Note: the exported subprograms in this package body are called directly
|
|
|
69 -- from C clients using the given external name, even though they are not
|
|
|
70 -- technically visible in the Ada sense.
|
|
|
71
|
|
|
72 function Code_Address_For_AAA return System.Address;
|
|
|
73 function Code_Address_For_ZZZ return System.Address;
|
|
|
74 -- Return start and end of procedures in this package
|
|
|
75 --
|
|
|
76 -- These procedures are used to provide exclusion bounds in
|
|
|
77 -- calls to Call_Chain at exception raise points from this unit. The
|
|
|
78 -- purpose is to arrange for the exception tracebacks not to include
|
|
|
79 -- frames from subprograms involved in the raise process, as these are
|
|
|
80 -- meaningless from the user's standpoint.
|
|
|
81 --
|
|
|
82 -- For these bounds to be meaningful, we need to ensure that the object
|
|
|
83 -- code for the subprograms involved in processing a raise is located
|
|
|
84 -- after the object code Code_Address_For_AAA and before the object
|
|
|
85 -- code Code_Address_For_ZZZ. This will indeed be the case as long as
|
|
|
86 -- the following rules are respected:
|
|
|
87 --
|
|
|
88 -- 1) The bodies of the subprograms involved in processing a raise
|
|
|
89 -- are located after the body of Code_Address_For_AAA and before the
|
|
|
90 -- body of Code_Address_For_ZZZ.
|
|
|
91 --
|
|
|
92 -- 2) No pragma Inline applies to any of these subprograms, as this
|
|
|
93 -- could delay the corresponding assembly output until the end of
|
|
|
94 -- the unit.
|
|
|
95
|
|
|
96 procedure Call_Chain (Excep : EOA);
|
|
|
97 -- Store up to Max_Tracebacks in Excep, corresponding to the current
|
|
|
98 -- call chain.
|
|
|
99
|
|
|
100 function Image (Index : Integer) return String;
|
|
|
101 -- Return string image corresponding to Index
|
|
|
102
|
|
|
103 procedure To_Stderr (S : String);
|
|
|
104 pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
|
|
|
105 -- Little routine to output string to stderr that is also used
|
|
|
106 -- in the tasking run time.
|
|
|
107
|
|
|
108 procedure To_Stderr (C : Character);
|
|
|
109 pragma Inline (To_Stderr);
|
|
|
110 pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char");
|
|
|
111 -- Little routine to output a character to stderr, used by some of
|
|
|
112 -- the separate units below.
|
|
|
113
|
|
|
114 package Exception_Data is
|
|
|
115
|
|
|
116 -----------------------------------
|
|
|
117 -- Exception Message Subprograms --
|
|
|
118 -----------------------------------
|
|
|
119
|
|
|
120 procedure Set_Exception_C_Msg
|
|
|
121 (Excep : EOA;
|
|
|
122 Id : Exception_Id;
|
|
|
123 Msg1 : System.Address;
|
|
|
124 Line : Integer := 0;
|
|
|
125 Column : Integer := 0;
|
|
|
126 Msg2 : System.Address := System.Null_Address);
|
|
|
127 -- This routine is called to setup the exception referenced by X
|
|
|
128 -- to contain the indicated Id value and message. Msg1 is a null
|
|
|
129 -- terminated string which is generated as the exception message. If
|
|
|
130 -- line is non-zero, then a colon and the decimal representation of
|
|
|
131 -- this integer is appended to the message. Ditto for Column. When Msg2
|
|
|
132 -- is non-null, a space and this additional null terminated string is
|
|
|
133 -- added to the message.
|
|
|
134
|
|
|
135 procedure Set_Exception_Msg
|
|
|
136 (Excep : EOA;
|
|
|
137 Id : Exception_Id;
|
|
|
138 Message : String);
|
|
|
139 -- This routine is called to setup the exception referenced by X
|
|
|
140 -- to contain the indicated Id value and message. Message is a string
|
|
|
141 -- which is generated as the exception message.
|
|
|
142
|
|
|
143 ---------------------------------------
|
|
|
144 -- Exception Information Subprograms --
|
|
|
145 ---------------------------------------
|
|
|
146
|
|
|
147 function Untailored_Exception_Information
|
|
|
148 (X : Exception_Occurrence) return String;
|
|
|
149 -- This is used by Stream_Attributes.EO_To_String to convert an
|
|
|
150 -- Exception_Occurrence to a String for the stream attributes.
|
|
|
151 -- String_To_EO understands the format, as documented here.
|
|
|
152 --
|
|
|
153 -- The format of the string is as follows:
|
|
|
154 --
|
|
|
155 -- raised <exception name> : <message>
|
|
|
156 -- (" : <message>" is present only if Exception_Message is not empty)
|
|
|
157 -- PID=nnnn (only if nonzero)
|
|
|
158 -- Call stack traceback locations: (only if at least one location)
|
|
|
159 -- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded)
|
|
|
160 --
|
|
|
161 -- The lines are separated by a ASCII.LF character.
|
|
|
162 -- The nnnn is the partition Id given as decimal digits.
|
|
|
163 -- The 0x... line represents traceback program counter locations, in
|
|
|
164 -- execution order with the first one being the exception location.
|
|
|
165 --
|
|
|
166 -- The Exception_Name and Message lines are omitted in the abort
|
|
|
167 -- signal case, since this is not really an exception.
|
|
|
168 --
|
|
|
169 -- Note: If the format of the generated string is changed, please note
|
|
|
170 -- that an equivalent modification to the routine String_To_EO must be
|
|
|
171 -- made to preserve proper functioning of the stream attributes.
|
|
|
172
|
|
|
173 function Exception_Information (X : Exception_Occurrence) return String;
|
|
|
174 -- This is the implementation of Ada.Exceptions.Exception_Information,
|
|
|
175 -- as defined in the Ada RM.
|
|
|
176 --
|
|
|
177 -- If no traceback decorator (see GNAT.Exception_Traces) is currently
|
|
|
178 -- in place, this is the same as Untailored_Exception_Information.
|
|
|
179 -- Otherwise, the decorator is used to produce a symbolic traceback
|
|
|
180 -- instead of hexadecimal addresses.
|
|
|
181 --
|
|
|
182 -- Note that unlike Untailored_Exception_Information, there is no need
|
|
|
183 -- to keep the output of Exception_Information stable for streaming
|
|
|
184 -- purposes, and in fact the output differs across platforms.
|
|
|
185
|
|
|
186 end Exception_Data;
|
|
|
187
|
|
|
188 package Exception_Traces is
|
|
|
189
|
|
|
190 -------------------------------------------------
|
|
|
191 -- Run-Time Exception Notification Subprograms --
|
|
|
192 -------------------------------------------------
|
|
|
193
|
|
|
194 -- These subprograms provide a common run-time interface to trigger the
|
|
|
195 -- actions required when an exception is about to be propagated (e.g.
|
|
|
196 -- user specified actions or output of exception information). They are
|
|
|
197 -- exported to be usable by the Ada exception handling personality
|
|
|
198 -- routine when the GCC 3 mechanism is used.
|
|
|
199
|
|
|
200 procedure Notify_Handled_Exception (Excep : EOA);
|
|
|
201 pragma Export
|
|
|
202 (C, Notify_Handled_Exception, "__gnat_notify_handled_exception");
|
|
|
203 -- This routine is called for a handled occurrence is about to be
|
|
|
204 -- propagated.
|
|
|
205
|
|
|
206 procedure Notify_Unhandled_Exception (Excep : EOA);
|
|
|
207 pragma Export
|
|
|
208 (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception");
|
|
|
209 -- This routine is called when an unhandled occurrence is about to be
|
|
|
210 -- propagated.
|
|
|
211
|
|
|
212 procedure Unhandled_Exception_Terminate (Excep : EOA);
|
|
|
213 pragma No_Return (Unhandled_Exception_Terminate);
|
|
|
214 -- This procedure is called to terminate execution following an
|
|
|
215 -- unhandled exception. The exception information, including
|
|
|
216 -- traceback if available is output, and execution is then
|
|
|
217 -- terminated. Note that at the point where this routine is
|
|
|
218 -- called, the stack has typically been destroyed.
|
|
|
219
|
|
|
220 end Exception_Traces;
|
|
|
221
|
|
|
222 package Exception_Propagation is
|
|
|
223
|
|
|
224 ---------------------------------------
|
|
|
225 -- Exception Propagation Subprograms --
|
|
|
226 ---------------------------------------
|
|
|
227
|
|
|
228 function Allocate_Occurrence return EOA;
|
|
|
229 -- Allocate an exception occurrence (as well as the machine occurrence)
|
|
|
230
|
|
131
|
231 procedure Propagate_Exception (Excep : Exception_Occurrence);
|
|
111
|
232 pragma No_Return (Propagate_Exception);
|
|
|
233 -- This procedure propagates the exception represented by Excep
|
|
|
234
|
|
|
235 end Exception_Propagation;
|
|
|
236
|
|
|
237 package Stream_Attributes is
|
|
|
238
|
|
|
239 ----------------------------------
|
|
|
240 -- Stream Attribute Subprograms --
|
|
|
241 ----------------------------------
|
|
|
242
|
|
|
243 function EId_To_String (X : Exception_Id) return String;
|
|
|
244 function String_To_EId (S : String) return Exception_Id;
|
|
|
245 -- Functions for implementing Exception_Id stream attributes
|
|
|
246
|
|
|
247 function EO_To_String (X : Exception_Occurrence) return String;
|
|
|
248 function String_To_EO (S : String) return Exception_Occurrence;
|
|
|
249 -- Functions for implementing Exception_Occurrence stream
|
|
|
250 -- attributes
|
|
|
251
|
|
|
252 end Stream_Attributes;
|
|
|
253
|
|
|
254 procedure Complete_Occurrence (X : EOA);
|
|
|
255 -- Finish building the occurrence: save the call chain and notify the
|
|
|
256 -- debugger.
|
|
|
257
|
|
|
258 procedure Complete_And_Propagate_Occurrence (X : EOA);
|
|
|
259 pragma No_Return (Complete_And_Propagate_Occurrence);
|
|
|
260 -- This is a simple wrapper to Complete_Occurrence and
|
|
|
261 -- Exception_Propagation.Propagate_Exception.
|
|
|
262
|
|
|
263 function Create_Occurrence_From_Signal_Handler
|
|
|
264 (E : Exception_Id;
|
|
|
265 M : System.Address) return EOA;
|
|
|
266 -- Create and build an exception occurrence using exception id E and
|
|
|
267 -- nul-terminated message M.
|
|
|
268
|
|
|
269 function Create_Machine_Occurrence_From_Signal_Handler
|
|
|
270 (E : Exception_Id;
|
|
|
271 M : System.Address) return System.Address;
|
|
|
272 pragma Export (C, Create_Machine_Occurrence_From_Signal_Handler,
|
|
|
273 "__gnat_create_machine_occurrence_from_signal_handler");
|
|
|
274 -- Create and build an exception occurrence using exception id E and
|
|
|
275 -- nul-terminated message M. Return the machine occurrence.
|
|
|
276
|
|
|
277 procedure Raise_Exception_No_Defer
|
|
|
278 (E : Exception_Id;
|
|
|
279 Message : String := "");
|
|
|
280 pragma Export
|
|
|
281 (Ada, Raise_Exception_No_Defer,
|
|
|
282 "ada__exceptions__raise_exception_no_defer");
|
|
|
283 pragma No_Return (Raise_Exception_No_Defer);
|
|
|
284 -- Similar to Raise_Exception, but with no abort deferral
|
|
|
285
|
|
|
286 procedure Raise_With_Msg (E : Exception_Id);
|
|
|
287 pragma No_Return (Raise_With_Msg);
|
|
|
288 pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
|
|
|
289 -- Raises an exception with given exception id value. A message
|
|
|
290 -- is associated with the raise, and has already been stored in the
|
|
|
291 -- exception occurrence referenced by the Current_Excep in the TSD.
|
|
|
292 -- Abort is deferred before the raise call.
|
|
|
293
|
|
|
294 procedure Raise_With_Location_And_Msg
|
|
|
295 (E : Exception_Id;
|
|
|
296 F : System.Address;
|
|
|
297 L : Integer;
|
|
|
298 C : Integer := 0;
|
|
|
299 M : System.Address := System.Null_Address);
|
|
|
300 pragma No_Return (Raise_With_Location_And_Msg);
|
|
|
301 -- Raise an exception with given exception id value. A filename and line
|
|
|
302 -- number is associated with the raise and is stored in the exception
|
|
|
303 -- occurrence and in addition a column and a string message M may be
|
|
|
304 -- appended to this (if not null/0).
|
|
|
305
|
|
|
306 procedure Raise_Constraint_Error (File : System.Address; Line : Integer);
|
|
|
307 pragma No_Return (Raise_Constraint_Error);
|
|
|
308 pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
|
|
|
309 -- Raise constraint error with file:line information
|
|
|
310
|
|
|
311 procedure Raise_Constraint_Error_Msg
|
|
|
312 (File : System.Address;
|
|
|
313 Line : Integer;
|
|
|
314 Column : Integer;
|
|
|
315 Msg : System.Address);
|
|
|
316 pragma No_Return (Raise_Constraint_Error_Msg);
|
|
|
317 pragma Export
|
|
|
318 (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
|
|
|
319 -- Raise constraint error with file:line:col + msg information
|
|
|
320
|
|
|
321 procedure Raise_Program_Error (File : System.Address; Line : Integer);
|
|
|
322 pragma No_Return (Raise_Program_Error);
|
|
|
323 pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error");
|
|
|
324 -- Raise program error with file:line information
|
|
|
325
|
|
|
326 procedure Raise_Program_Error_Msg
|
|
|
327 (File : System.Address;
|
|
|
328 Line : Integer;
|
|
|
329 Msg : System.Address);
|
|
|
330 pragma No_Return (Raise_Program_Error_Msg);
|
|
|
331 pragma Export
|
|
|
332 (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg");
|
|
|
333 -- Raise program error with file:line + msg information
|
|
|
334
|
|
|
335 procedure Raise_Storage_Error (File : System.Address; Line : Integer);
|
|
|
336 pragma No_Return (Raise_Storage_Error);
|
|
|
337 pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error");
|
|
|
338 -- Raise storage error with file:line information
|
|
|
339
|
|
|
340 procedure Raise_Storage_Error_Msg
|
|
|
341 (File : System.Address;
|
|
|
342 Line : Integer;
|
|
|
343 Msg : System.Address);
|
|
|
344 pragma No_Return (Raise_Storage_Error_Msg);
|
|
|
345 pragma Export
|
|
|
346 (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg");
|
|
|
347 -- Raise storage error with file:line + reason msg information
|
|
|
348
|
|
|
349 -- The exception raising process and the automatic tracing mechanism rely
|
|
|
350 -- on some careful use of flags attached to the exception occurrence. The
|
|
|
351 -- graph below illustrates the relations between the Raise_ subprograms
|
|
|
352 -- and identifies the points where basic flags such as Exception_Raised
|
|
|
353 -- are initialized.
|
|
|
354
|
|
|
355 -- (i) signs indicate the flags initialization points. R stands for Raise,
|
|
|
356 -- W for With, and E for Exception.
|
|
|
357
|
|
|
358 -- R_No_Msg R_E R_Pe R_Ce R_Se
|
|
|
359 -- | | | | |
|
|
|
360 -- +--+ +--+ +---+ | +---+
|
|
|
361 -- | | | | |
|
|
|
362 -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc
|
|
|
363 -- | | | |
|
|
|
364 -- +------------+ | +-----------+ +--+
|
|
|
365 -- | | | |
|
|
|
366 -- | | | Set_E_C_Msg(i)
|
|
|
367 -- | | |
|
|
|
368 -- Complete_And_Propagate_Occurrence
|
|
|
369
|
|
|
370 procedure Reraise;
|
|
|
371 pragma No_Return (Reraise);
|
|
|
372 pragma Export (C, Reraise, "__gnat_reraise");
|
|
|
373 -- Reraises the exception referenced by the Current_Excep field
|
|
|
374 -- of the TSD (all fields of this exception occurrence are set).
|
|
|
375 -- Abort is deferred before the reraise operation. Called from
|
|
|
376 -- System.Tasking.RendezVous.Exceptional_Complete_RendezVous
|
|
|
377
|
|
|
378 procedure Transfer_Occurrence
|
|
|
379 (Target : Exception_Occurrence_Access;
|
|
|
380 Source : Exception_Occurrence);
|
|
|
381 pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
|
|
|
382 -- Called from s-tasren.adb:Local_Complete_RendezVous and
|
|
|
383 -- s-tpobop.adb:Exceptional_Complete_Entry_Body to setup Target from
|
|
|
384 -- Source as an exception to be propagated in the caller task. Target is
|
|
|
385 -- expected to be a pointer to the fixed TSD occurrence for this task.
|
|
|
386
|
|
|
387 --------------------------------
|
|
|
388 -- Run-Time Check Subprograms --
|
|
|
389 --------------------------------
|
|
|
390
|
|
|
391 -- These subprograms raise a specific exception with a reason message
|
|
|
392 -- attached. The parameters are the file name and line number in each
|
|
|
393 -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name.
|
|
|
394
|
|
|
395 procedure Rcheck_CE_Access_Check
|
|
|
396 (File : System.Address; Line : Integer);
|
|
|
397 procedure Rcheck_CE_Null_Access_Parameter
|
|
|
398 (File : System.Address; Line : Integer);
|
|
|
399 procedure Rcheck_CE_Discriminant_Check
|
|
|
400 (File : System.Address; Line : Integer);
|
|
|
401 procedure Rcheck_CE_Divide_By_Zero
|
|
|
402 (File : System.Address; Line : Integer);
|
|
|
403 procedure Rcheck_CE_Explicit_Raise
|
|
|
404 (File : System.Address; Line : Integer);
|
|
|
405 procedure Rcheck_CE_Index_Check
|
|
|
406 (File : System.Address; Line : Integer);
|
|
|
407 procedure Rcheck_CE_Invalid_Data
|
|
|
408 (File : System.Address; Line : Integer);
|
|
|
409 procedure Rcheck_CE_Length_Check
|
|
|
410 (File : System.Address; Line : Integer);
|
|
|
411 procedure Rcheck_CE_Null_Exception_Id
|
|
|
412 (File : System.Address; Line : Integer);
|
|
|
413 procedure Rcheck_CE_Null_Not_Allowed
|
|
|
414 (File : System.Address; Line : Integer);
|
|
|
415 procedure Rcheck_CE_Overflow_Check
|
|
|
416 (File : System.Address; Line : Integer);
|
|
|
417 procedure Rcheck_CE_Partition_Check
|
|
|
418 (File : System.Address; Line : Integer);
|
|
|
419 procedure Rcheck_CE_Range_Check
|
|
|
420 (File : System.Address; Line : Integer);
|
|
|
421 procedure Rcheck_CE_Tag_Check
|
|
|
422 (File : System.Address; Line : Integer);
|
|
|
423 procedure Rcheck_PE_Access_Before_Elaboration
|
|
|
424 (File : System.Address; Line : Integer);
|
|
|
425 procedure Rcheck_PE_Accessibility_Check
|
|
|
426 (File : System.Address; Line : Integer);
|
|
|
427 procedure Rcheck_PE_Address_Of_Intrinsic
|
|
|
428 (File : System.Address; Line : Integer);
|
|
|
429 procedure Rcheck_PE_Aliased_Parameters
|
|
|
430 (File : System.Address; Line : Integer);
|
|
|
431 procedure Rcheck_PE_All_Guards_Closed
|
|
|
432 (File : System.Address; Line : Integer);
|
|
|
433 procedure Rcheck_PE_Bad_Predicated_Generic_Type
|
|
|
434 (File : System.Address; Line : Integer);
|
|
131
|
435 procedure Rcheck_PE_Build_In_Place_Mismatch
|
|
|
436 (File : System.Address; Line : Integer);
|
|
111
|
437 procedure Rcheck_PE_Current_Task_In_Entry_Body
|
|
|
438 (File : System.Address; Line : Integer);
|
|
|
439 procedure Rcheck_PE_Duplicated_Entry_Address
|
|
|
440 (File : System.Address; Line : Integer);
|
|
|
441 procedure Rcheck_PE_Explicit_Raise
|
|
|
442 (File : System.Address; Line : Integer);
|
|
|
443 procedure Rcheck_PE_Implicit_Return
|
|
|
444 (File : System.Address; Line : Integer);
|
|
|
445 procedure Rcheck_PE_Misaligned_Address_Value
|
|
|
446 (File : System.Address; Line : Integer);
|
|
|
447 procedure Rcheck_PE_Missing_Return
|
|
|
448 (File : System.Address; Line : Integer);
|
|
|
449 procedure Rcheck_PE_Non_Transportable_Actual
|
|
|
450 (File : System.Address; Line : Integer);
|
|
|
451 procedure Rcheck_PE_Overlaid_Controlled_Object
|
|
|
452 (File : System.Address; Line : Integer);
|
|
|
453 procedure Rcheck_PE_Potentially_Blocking_Operation
|
|
|
454 (File : System.Address; Line : Integer);
|
|
|
455 procedure Rcheck_PE_Stubbed_Subprogram_Called
|
|
|
456 (File : System.Address; Line : Integer);
|
|
|
457 procedure Rcheck_PE_Unchecked_Union_Restriction
|
|
|
458 (File : System.Address; Line : Integer);
|
|
|
459 procedure Rcheck_SE_Empty_Storage_Pool
|
|
|
460 (File : System.Address; Line : Integer);
|
|
|
461 procedure Rcheck_SE_Explicit_Raise
|
|
|
462 (File : System.Address; Line : Integer);
|
|
|
463 procedure Rcheck_SE_Infinite_Recursion
|
|
|
464 (File : System.Address; Line : Integer);
|
|
|
465 procedure Rcheck_SE_Object_Too_Large
|
|
|
466 (File : System.Address; Line : Integer);
|
|
|
467 procedure Rcheck_PE_Stream_Operation_Not_Allowed
|
|
|
468 (File : System.Address; Line : Integer);
|
|
|
469 procedure Rcheck_CE_Access_Check_Ext
|
|
|
470 (File : System.Address; Line, Column : Integer);
|
|
|
471 procedure Rcheck_CE_Index_Check_Ext
|
|
|
472 (File : System.Address; Line, Column, Index, First, Last : Integer);
|
|
|
473 procedure Rcheck_CE_Invalid_Data_Ext
|
|
|
474 (File : System.Address; Line, Column, Index, First, Last : Integer);
|
|
|
475 procedure Rcheck_CE_Range_Check_Ext
|
|
|
476 (File : System.Address; Line, Column, Index, First, Last : Integer);
|
|
|
477
|
|
|
478 procedure Rcheck_PE_Finalize_Raised_Exception
|
|
|
479 (File : System.Address; Line : Integer);
|
|
|
480 -- This routine is separated out because it has quite different behavior
|
|
|
481 -- from the others. This is the "finalize/adjust raised exception". This
|
|
|
482 -- subprogram is always called with abort deferred, unlike all other
|
|
|
483 -- Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer.
|
|
|
484
|
|
|
485 pragma Export (C, Rcheck_CE_Access_Check,
|
|
|
486 "__gnat_rcheck_CE_Access_Check");
|
|
|
487 pragma Export (C, Rcheck_CE_Null_Access_Parameter,
|
|
|
488 "__gnat_rcheck_CE_Null_Access_Parameter");
|
|
|
489 pragma Export (C, Rcheck_CE_Discriminant_Check,
|
|
|
490 "__gnat_rcheck_CE_Discriminant_Check");
|
|
|
491 pragma Export (C, Rcheck_CE_Divide_By_Zero,
|
|
|
492 "__gnat_rcheck_CE_Divide_By_Zero");
|
|
|
493 pragma Export (C, Rcheck_CE_Explicit_Raise,
|
|
|
494 "__gnat_rcheck_CE_Explicit_Raise");
|
|
|
495 pragma Export (C, Rcheck_CE_Index_Check,
|
|
|
496 "__gnat_rcheck_CE_Index_Check");
|
|
|
497 pragma Export (C, Rcheck_CE_Invalid_Data,
|
|
|
498 "__gnat_rcheck_CE_Invalid_Data");
|
|
|
499 pragma Export (C, Rcheck_CE_Length_Check,
|
|
|
500 "__gnat_rcheck_CE_Length_Check");
|
|
|
501 pragma Export (C, Rcheck_CE_Null_Exception_Id,
|
|
|
502 "__gnat_rcheck_CE_Null_Exception_Id");
|
|
|
503 pragma Export (C, Rcheck_CE_Null_Not_Allowed,
|
|
|
504 "__gnat_rcheck_CE_Null_Not_Allowed");
|
|
|
505 pragma Export (C, Rcheck_CE_Overflow_Check,
|
|
|
506 "__gnat_rcheck_CE_Overflow_Check");
|
|
|
507 pragma Export (C, Rcheck_CE_Partition_Check,
|
|
|
508 "__gnat_rcheck_CE_Partition_Check");
|
|
|
509 pragma Export (C, Rcheck_CE_Range_Check,
|
|
|
510 "__gnat_rcheck_CE_Range_Check");
|
|
|
511 pragma Export (C, Rcheck_CE_Tag_Check,
|
|
|
512 "__gnat_rcheck_CE_Tag_Check");
|
|
|
513 pragma Export (C, Rcheck_PE_Access_Before_Elaboration,
|
|
|
514 "__gnat_rcheck_PE_Access_Before_Elaboration");
|
|
|
515 pragma Export (C, Rcheck_PE_Accessibility_Check,
|
|
|
516 "__gnat_rcheck_PE_Accessibility_Check");
|
|
|
517 pragma Export (C, Rcheck_PE_Address_Of_Intrinsic,
|
|
|
518 "__gnat_rcheck_PE_Address_Of_Intrinsic");
|
|
|
519 pragma Export (C, Rcheck_PE_Aliased_Parameters,
|
|
|
520 "__gnat_rcheck_PE_Aliased_Parameters");
|
|
|
521 pragma Export (C, Rcheck_PE_All_Guards_Closed,
|
|
|
522 "__gnat_rcheck_PE_All_Guards_Closed");
|
|
|
523 pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type,
|
|
|
524 "__gnat_rcheck_PE_Bad_Predicated_Generic_Type");
|
|
131
|
525 pragma Export (C, Rcheck_PE_Build_In_Place_Mismatch,
|
|
|
526 "__gnat_rcheck_PE_Build_In_Place_Mismatch");
|
|
111
|
527 pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body,
|
|
|
528 "__gnat_rcheck_PE_Current_Task_In_Entry_Body");
|
|
|
529 pragma Export (C, Rcheck_PE_Duplicated_Entry_Address,
|
|
|
530 "__gnat_rcheck_PE_Duplicated_Entry_Address");
|
|
|
531 pragma Export (C, Rcheck_PE_Explicit_Raise,
|
|
|
532 "__gnat_rcheck_PE_Explicit_Raise");
|
|
|
533 pragma Export (C, Rcheck_PE_Finalize_Raised_Exception,
|
|
|
534 "__gnat_rcheck_PE_Finalize_Raised_Exception");
|
|
|
535 pragma Export (C, Rcheck_PE_Implicit_Return,
|
|
|
536 "__gnat_rcheck_PE_Implicit_Return");
|
|
|
537 pragma Export (C, Rcheck_PE_Misaligned_Address_Value,
|
|
|
538 "__gnat_rcheck_PE_Misaligned_Address_Value");
|
|
|
539 pragma Export (C, Rcheck_PE_Missing_Return,
|
|
|
540 "__gnat_rcheck_PE_Missing_Return");
|
|
|
541 pragma Export (C, Rcheck_PE_Non_Transportable_Actual,
|
|
|
542 "__gnat_rcheck_PE_Non_Transportable_Actual");
|
|
|
543 pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object,
|
|
|
544 "__gnat_rcheck_PE_Overlaid_Controlled_Object");
|
|
|
545 pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation,
|
|
|
546 "__gnat_rcheck_PE_Potentially_Blocking_Operation");
|
|
|
547 pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed,
|
|
|
548 "__gnat_rcheck_PE_Stream_Operation_Not_Allowed");
|
|
|
549 pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called,
|
|
|
550 "__gnat_rcheck_PE_Stubbed_Subprogram_Called");
|
|
|
551 pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction,
|
|
|
552 "__gnat_rcheck_PE_Unchecked_Union_Restriction");
|
|
|
553 pragma Export (C, Rcheck_SE_Empty_Storage_Pool,
|
|
|
554 "__gnat_rcheck_SE_Empty_Storage_Pool");
|
|
|
555 pragma Export (C, Rcheck_SE_Explicit_Raise,
|
|
|
556 "__gnat_rcheck_SE_Explicit_Raise");
|
|
|
557 pragma Export (C, Rcheck_SE_Infinite_Recursion,
|
|
|
558 "__gnat_rcheck_SE_Infinite_Recursion");
|
|
|
559 pragma Export (C, Rcheck_SE_Object_Too_Large,
|
|
|
560 "__gnat_rcheck_SE_Object_Too_Large");
|
|
|
561
|
|
|
562 pragma Export (C, Rcheck_CE_Access_Check_Ext,
|
|
|
563 "__gnat_rcheck_CE_Access_Check_ext");
|
|
|
564 pragma Export (C, Rcheck_CE_Index_Check_Ext,
|
|
|
565 "__gnat_rcheck_CE_Index_Check_ext");
|
|
|
566 pragma Export (C, Rcheck_CE_Invalid_Data_Ext,
|
|
|
567 "__gnat_rcheck_CE_Invalid_Data_ext");
|
|
|
568 pragma Export (C, Rcheck_CE_Range_Check_Ext,
|
|
|
569 "__gnat_rcheck_CE_Range_Check_ext");
|
|
|
570
|
|
|
571 -- None of these procedures ever returns (they raise an exception). By
|
|
|
572 -- using pragma No_Return, we ensure that any junk code after the call,
|
|
|
573 -- such as normal return epilogue stuff, can be eliminated).
|
|
|
574
|
|
|
575 pragma No_Return (Rcheck_CE_Access_Check);
|
|
|
576 pragma No_Return (Rcheck_CE_Null_Access_Parameter);
|
|
|
577 pragma No_Return (Rcheck_CE_Discriminant_Check);
|
|
|
578 pragma No_Return (Rcheck_CE_Divide_By_Zero);
|
|
|
579 pragma No_Return (Rcheck_CE_Explicit_Raise);
|
|
|
580 pragma No_Return (Rcheck_CE_Index_Check);
|
|
|
581 pragma No_Return (Rcheck_CE_Invalid_Data);
|
|
|
582 pragma No_Return (Rcheck_CE_Length_Check);
|
|
|
583 pragma No_Return (Rcheck_CE_Null_Exception_Id);
|
|
|
584 pragma No_Return (Rcheck_CE_Null_Not_Allowed);
|
|
|
585 pragma No_Return (Rcheck_CE_Overflow_Check);
|
|
|
586 pragma No_Return (Rcheck_CE_Partition_Check);
|
|
|
587 pragma No_Return (Rcheck_CE_Range_Check);
|
|
|
588 pragma No_Return (Rcheck_CE_Tag_Check);
|
|
|
589 pragma No_Return (Rcheck_PE_Access_Before_Elaboration);
|
|
|
590 pragma No_Return (Rcheck_PE_Accessibility_Check);
|
|
|
591 pragma No_Return (Rcheck_PE_Address_Of_Intrinsic);
|
|
|
592 pragma No_Return (Rcheck_PE_Aliased_Parameters);
|
|
|
593 pragma No_Return (Rcheck_PE_All_Guards_Closed);
|
|
|
594 pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type);
|
|
131
|
595 pragma No_Return (Rcheck_PE_Build_In_Place_Mismatch);
|
|
111
|
596 pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body);
|
|
|
597 pragma No_Return (Rcheck_PE_Duplicated_Entry_Address);
|
|
|
598 pragma No_Return (Rcheck_PE_Explicit_Raise);
|
|
|
599 pragma No_Return (Rcheck_PE_Implicit_Return);
|
|
|
600 pragma No_Return (Rcheck_PE_Misaligned_Address_Value);
|
|
|
601 pragma No_Return (Rcheck_PE_Missing_Return);
|
|
|
602 pragma No_Return (Rcheck_PE_Non_Transportable_Actual);
|
|
|
603 pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object);
|
|
|
604 pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation);
|
|
|
605 pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed);
|
|
|
606 pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called);
|
|
|
607 pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction);
|
|
|
608 pragma No_Return (Rcheck_PE_Finalize_Raised_Exception);
|
|
|
609 pragma No_Return (Rcheck_SE_Empty_Storage_Pool);
|
|
|
610 pragma No_Return (Rcheck_SE_Explicit_Raise);
|
|
|
611 pragma No_Return (Rcheck_SE_Infinite_Recursion);
|
|
|
612 pragma No_Return (Rcheck_SE_Object_Too_Large);
|
|
|
613
|
|
|
614 pragma No_Return (Rcheck_CE_Access_Check_Ext);
|
|
|
615 pragma No_Return (Rcheck_CE_Index_Check_Ext);
|
|
|
616 pragma No_Return (Rcheck_CE_Invalid_Data_Ext);
|
|
|
617 pragma No_Return (Rcheck_CE_Range_Check_Ext);
|
|
|
618
|
|
|
619 ---------------------------------------------
|
|
|
620 -- Reason Strings for Run-Time Check Calls --
|
|
|
621 ---------------------------------------------
|
|
|
622
|
|
|
623 -- These strings are null-terminated and are used by Rcheck_nn. The
|
|
|
624 -- strings correspond to the definitions for Types.RT_Exception_Code.
|
|
|
625
|
|
|
626 use ASCII;
|
|
|
627
|
|
|
628 Rmsg_00 : constant String := "access check failed" & NUL;
|
|
|
629 Rmsg_01 : constant String := "access parameter is null" & NUL;
|
|
|
630 Rmsg_02 : constant String := "discriminant check failed" & NUL;
|
|
|
631 Rmsg_03 : constant String := "divide by zero" & NUL;
|
|
|
632 Rmsg_04 : constant String := "explicit raise" & NUL;
|
|
|
633 Rmsg_05 : constant String := "index check failed" & NUL;
|
|
|
634 Rmsg_06 : constant String := "invalid data" & NUL;
|
|
|
635 Rmsg_07 : constant String := "length check failed" & NUL;
|
|
|
636 Rmsg_08 : constant String := "null Exception_Id" & NUL;
|
|
|
637 Rmsg_09 : constant String := "null-exclusion check failed" & NUL;
|
|
|
638 Rmsg_10 : constant String := "overflow check failed" & NUL;
|
|
|
639 Rmsg_11 : constant String := "partition check failed" & NUL;
|
|
|
640 Rmsg_12 : constant String := "range check failed" & NUL;
|
|
|
641 Rmsg_13 : constant String := "tag check failed" & NUL;
|
|
|
642 Rmsg_14 : constant String := "access before elaboration" & NUL;
|
|
|
643 Rmsg_15 : constant String := "accessibility check failed" & NUL;
|
|
|
644 Rmsg_16 : constant String := "attempt to take address of" &
|
|
|
645 " intrinsic subprogram" & NUL;
|
|
|
646 Rmsg_17 : constant String := "aliased parameters" & NUL;
|
|
|
647 Rmsg_18 : constant String := "all guards closed" & NUL;
|
|
|
648 Rmsg_19 : constant String := "improper use of generic subtype" &
|
|
|
649 " with predicate" & NUL;
|
|
|
650 Rmsg_20 : constant String := "Current_Task referenced in entry" &
|
|
|
651 " body" & NUL;
|
|
|
652 Rmsg_21 : constant String := "duplicated entry address" & NUL;
|
|
|
653 Rmsg_22 : constant String := "explicit raise" & NUL;
|
|
|
654 Rmsg_23 : constant String := "finalize/adjust raised exception" & NUL;
|
|
|
655 Rmsg_24 : constant String := "implicit return with No_Return" & NUL;
|
|
|
656 Rmsg_25 : constant String := "misaligned address value" & NUL;
|
|
|
657 Rmsg_26 : constant String := "missing return" & NUL;
|
|
|
658 Rmsg_27 : constant String := "overlaid controlled object" & NUL;
|
|
|
659 Rmsg_28 : constant String := "potentially blocking operation" & NUL;
|
|
|
660 Rmsg_29 : constant String := "stubbed subprogram called" & NUL;
|
|
|
661 Rmsg_30 : constant String := "unchecked union restriction" & NUL;
|
|
|
662 Rmsg_31 : constant String := "actual/returned class-wide" &
|
|
|
663 " value not transportable" & NUL;
|
|
|
664 Rmsg_32 : constant String := "empty storage pool" & NUL;
|
|
|
665 Rmsg_33 : constant String := "explicit raise" & NUL;
|
|
|
666 Rmsg_34 : constant String := "infinite recursion" & NUL;
|
|
|
667 Rmsg_35 : constant String := "object too large" & NUL;
|
|
|
668 Rmsg_36 : constant String := "stream operation not allowed" & NUL;
|
|
131
|
669 Rmsg_37 : constant String := "build-in-place mismatch" & NUL;
|
|
111
|
670
|
|
|
671 -----------------------
|
|
|
672 -- Polling Interface --
|
|
|
673 -----------------------
|
|
|
674
|
|
|
675 type Unsigned is mod 2 ** 32;
|
|
|
676
|
|
|
677 Counter : Unsigned := 0;
|
|
|
678 pragma Warnings (Off, Counter);
|
|
|
679 -- This counter is provided for convenience. It can be used in Poll to
|
|
|
680 -- perform periodic but not systematic operations.
|
|
|
681
|
|
|
682 procedure Poll is separate;
|
|
|
683 -- The actual polling routine is separate, so that it can easily be
|
|
|
684 -- replaced with a target dependent version.
|
|
|
685
|
|
|
686 --------------------------
|
|
|
687 -- Code_Address_For_AAA --
|
|
|
688 --------------------------
|
|
|
689
|
|
|
690 -- This function gives us the start of the PC range for addresses within
|
|
|
691 -- the exception unit itself. We hope that gigi/gcc keep all the procedures
|
|
|
692 -- in their original order.
|
|
|
693
|
|
|
694 function Code_Address_For_AAA return System.Address is
|
|
|
695 begin
|
|
|
696 -- We are using a label instead of Code_Address_For_AAA'Address because
|
|
|
697 -- on some platforms the latter does not yield the address we want, but
|
|
|
698 -- the address of a stub or of a descriptor instead. This is the case at
|
|
|
699 -- least on PA-HPUX.
|
|
|
700
|
|
|
701 <<Start_Of_AAA>>
|
|
|
702 return Start_Of_AAA'Address;
|
|
|
703 end Code_Address_For_AAA;
|
|
|
704
|
|
|
705 ----------------
|
|
|
706 -- Call_Chain --
|
|
|
707 ----------------
|
|
|
708
|
|
|
709 procedure Call_Chain (Excep : EOA) is separate;
|
|
|
710 -- The actual Call_Chain routine is separate, so that it can easily
|
|
|
711 -- be dummied out when no exception traceback information is needed.
|
|
|
712
|
|
|
713 -------------------
|
|
|
714 -- EId_To_String --
|
|
|
715 -------------------
|
|
|
716
|
|
|
717 function EId_To_String (X : Exception_Id) return String
|
|
|
718 renames Stream_Attributes.EId_To_String;
|
|
|
719
|
|
|
720 ------------------
|
|
|
721 -- EO_To_String --
|
|
|
722 ------------------
|
|
|
723
|
|
|
724 -- We use the null string to represent the null occurrence, otherwise we
|
|
|
725 -- output the Untailored_Exception_Information string for the occurrence.
|
|
|
726
|
|
|
727 function EO_To_String (X : Exception_Occurrence) return String
|
|
|
728 renames Stream_Attributes.EO_To_String;
|
|
|
729
|
|
|
730 ------------------------
|
|
|
731 -- Exception_Identity --
|
|
|
732 ------------------------
|
|
|
733
|
|
|
734 function Exception_Identity
|
|
|
735 (X : Exception_Occurrence) return Exception_Id
|
|
|
736 is
|
|
|
737 begin
|
|
|
738 -- Note that the following test used to be here for the original
|
|
|
739 -- Ada 95 semantics, but these were modified by AI-241 to require
|
|
|
740 -- returning Null_Id instead of raising Constraint_Error.
|
|
|
741
|
|
|
742 -- if X.Id = Null_Id then
|
|
|
743 -- raise Constraint_Error;
|
|
|
744 -- end if;
|
|
|
745
|
|
|
746 return X.Id;
|
|
|
747 end Exception_Identity;
|
|
|
748
|
|
|
749 ---------------------------
|
|
|
750 -- Exception_Information --
|
|
|
751 ---------------------------
|
|
|
752
|
|
|
753 function Exception_Information (X : Exception_Occurrence) return String is
|
|
|
754 begin
|
|
|
755 if X.Id = Null_Id then
|
|
|
756 raise Constraint_Error;
|
|
|
757 else
|
|
|
758 return Exception_Data.Exception_Information (X);
|
|
|
759 end if;
|
|
|
760 end Exception_Information;
|
|
|
761
|
|
|
762 -----------------------
|
|
|
763 -- Exception_Message --
|
|
|
764 -----------------------
|
|
|
765
|
|
|
766 function Exception_Message (X : Exception_Occurrence) return String is
|
|
|
767 begin
|
|
|
768 if X.Id = Null_Id then
|
|
|
769 raise Constraint_Error;
|
|
|
770 else
|
|
|
771 return X.Msg (1 .. X.Msg_Length);
|
|
|
772 end if;
|
|
|
773 end Exception_Message;
|
|
|
774
|
|
|
775 --------------------
|
|
|
776 -- Exception_Name --
|
|
|
777 --------------------
|
|
|
778
|
|
|
779 function Exception_Name (Id : Exception_Id) return String is
|
|
|
780 begin
|
|
|
781 if Id = null then
|
|
|
782 raise Constraint_Error;
|
|
|
783 else
|
|
|
784 return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1);
|
|
|
785 end if;
|
|
|
786 end Exception_Name;
|
|
|
787
|
|
|
788 function Exception_Name (X : Exception_Occurrence) return String is
|
|
|
789 begin
|
|
|
790 return Exception_Name (X.Id);
|
|
|
791 end Exception_Name;
|
|
|
792
|
|
|
793 ---------------------------
|
|
|
794 -- Exception_Name_Simple --
|
|
|
795 ---------------------------
|
|
|
796
|
|
|
797 function Exception_Name_Simple (X : Exception_Occurrence) return String is
|
|
|
798 Name : constant String := Exception_Name (X);
|
|
|
799 P : Natural;
|
|
|
800
|
|
|
801 begin
|
|
|
802 P := Name'Length;
|
|
|
803 while P > 1 loop
|
|
|
804 exit when Name (P - 1) = '.';
|
|
|
805 P := P - 1;
|
|
|
806 end loop;
|
|
|
807
|
|
|
808 -- Return result making sure lower bound is 1
|
|
|
809
|
|
|
810 declare
|
|
|
811 subtype Rname is String (1 .. Name'Length - P + 1);
|
|
|
812 begin
|
|
|
813 return Rname (Name (P .. Name'Length));
|
|
|
814 end;
|
|
|
815 end Exception_Name_Simple;
|
|
|
816
|
|
|
817 --------------------
|
|
|
818 -- Exception_Data --
|
|
|
819 --------------------
|
|
|
820
|
|
|
821 package body Exception_Data is separate;
|
|
|
822 -- This package can be easily dummied out if we do not want the basic
|
|
|
823 -- support for exception messages (such as in Ada 83).
|
|
|
824
|
|
|
825 ---------------------------
|
|
|
826 -- Exception_Propagation --
|
|
|
827 ---------------------------
|
|
|
828
|
|
|
829 package body Exception_Propagation is separate;
|
|
|
830 -- Depending on the actual exception mechanism used (front-end or
|
|
|
831 -- back-end based), the implementation will differ, which is why this
|
|
|
832 -- package is separated.
|
|
|
833
|
|
|
834 ----------------------
|
|
|
835 -- Exception_Traces --
|
|
|
836 ----------------------
|
|
|
837
|
|
|
838 package body Exception_Traces is separate;
|
|
|
839 -- Depending on the underlying support for IO the implementation will
|
|
|
840 -- differ. Moreover we would like to dummy out this package in case we
|
|
|
841 -- do not want any exception tracing support. This is why this package
|
|
|
842 -- is separated.
|
|
|
843
|
|
|
844 --------------------------------------
|
|
|
845 -- Get_Exception_Machine_Occurrence --
|
|
|
846 --------------------------------------
|
|
|
847
|
|
|
848 function Get_Exception_Machine_Occurrence
|
|
|
849 (X : Exception_Occurrence) return System.Address
|
|
|
850 is
|
|
|
851 begin
|
|
|
852 return X.Machine_Occurrence;
|
|
|
853 end Get_Exception_Machine_Occurrence;
|
|
|
854
|
|
|
855 -----------
|
|
|
856 -- Image --
|
|
|
857 -----------
|
|
|
858
|
|
|
859 function Image (Index : Integer) return String is
|
|
|
860 Result : constant String := Integer'Image (Index);
|
|
|
861 begin
|
|
|
862 if Result (1) = ' ' then
|
|
|
863 return Result (2 .. Result'Last);
|
|
|
864 else
|
|
|
865 return Result;
|
|
|
866 end if;
|
|
|
867 end Image;
|
|
|
868
|
|
|
869 -----------------------
|
|
|
870 -- Stream Attributes --
|
|
|
871 -----------------------
|
|
|
872
|
|
|
873 package body Stream_Attributes is separate;
|
|
|
874 -- This package can be easily dummied out if we do not want the
|
|
|
875 -- support for streaming Exception_Ids and Exception_Occurrences.
|
|
|
876
|
|
|
877 ----------------------------
|
|
|
878 -- Raise_Constraint_Error --
|
|
|
879 ----------------------------
|
|
|
880
|
|
|
881 procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is
|
|
|
882 begin
|
|
|
883 Raise_With_Location_And_Msg (Constraint_Error_Def'Access, File, Line);
|
|
|
884 end Raise_Constraint_Error;
|
|
|
885
|
|
|
886 --------------------------------
|
|
|
887 -- Raise_Constraint_Error_Msg --
|
|
|
888 --------------------------------
|
|
|
889
|
|
|
890 procedure Raise_Constraint_Error_Msg
|
|
|
891 (File : System.Address;
|
|
|
892 Line : Integer;
|
|
|
893 Column : Integer;
|
|
|
894 Msg : System.Address)
|
|
|
895 is
|
|
|
896 begin
|
|
|
897 Raise_With_Location_And_Msg
|
|
|
898 (Constraint_Error_Def'Access, File, Line, Column, Msg);
|
|
|
899 end Raise_Constraint_Error_Msg;
|
|
|
900
|
|
|
901 -------------------------
|
|
|
902 -- Complete_Occurrence --
|
|
|
903 -------------------------
|
|
|
904
|
|
|
905 procedure Complete_Occurrence (X : EOA) is
|
|
|
906 begin
|
|
|
907 -- Compute the backtrace for this occurrence if the corresponding
|
|
|
908 -- binder option has been set. Call_Chain takes care of the reraise
|
|
|
909 -- case.
|
|
|
910
|
|
|
911 -- ??? Using Call_Chain here means we are going to walk up the stack
|
|
|
912 -- once only for backtracing purposes before doing it again for the
|
|
|
913 -- propagation per se.
|
|
|
914
|
|
|
915 -- The first inspection is much lighter, though, as it only requires
|
|
|
916 -- partial unwinding of each frame. Additionally, although we could use
|
|
|
917 -- the personality routine to record the addresses while propagating,
|
|
|
918 -- this method has two drawbacks:
|
|
|
919
|
|
|
920 -- 1) the trace is incomplete if the exception is handled since we
|
|
|
921 -- don't walk past the frame with the handler,
|
|
|
922
|
|
|
923 -- and
|
|
|
924
|
|
|
925 -- 2) we would miss the frames for which our personality routine is not
|
|
|
926 -- called, e.g. if C or C++ calls are on the way.
|
|
|
927
|
|
|
928 Call_Chain (X);
|
|
|
929
|
|
|
930 -- Notify the debugger
|
|
|
931 Debug_Raise_Exception
|
|
|
932 (E => SSL.Exception_Data_Ptr (X.Id),
|
|
|
933 Message => X.Msg (1 .. X.Msg_Length));
|
|
|
934 end Complete_Occurrence;
|
|
|
935
|
|
|
936 ---------------------------------------
|
|
|
937 -- Complete_And_Propagate_Occurrence --
|
|
|
938 ---------------------------------------
|
|
|
939
|
|
|
940 procedure Complete_And_Propagate_Occurrence (X : EOA) is
|
|
|
941 begin
|
|
|
942 Complete_Occurrence (X);
|
|
131
|
943 Exception_Propagation.Propagate_Exception (X.all);
|
|
111
|
944 end Complete_And_Propagate_Occurrence;
|
|
|
945
|
|
|
946 ---------------------
|
|
|
947 -- Raise_Exception --
|
|
|
948 ---------------------
|
|
|
949
|
|
|
950 procedure Raise_Exception
|
|
|
951 (E : Exception_Id;
|
|
|
952 Message : String := "")
|
|
|
953 is
|
|
|
954 EF : Exception_Id := E;
|
|
|
955 begin
|
|
|
956 -- Raise CE if E = Null_ID (AI-446)
|
|
|
957
|
|
|
958 if E = null then
|
|
|
959 EF := Constraint_Error'Identity;
|
|
|
960 end if;
|
|
|
961
|
|
|
962 -- Go ahead and raise appropriate exception
|
|
|
963
|
|
|
964 Raise_Exception_Always (EF, Message);
|
|
|
965 end Raise_Exception;
|
|
|
966
|
|
|
967 ----------------------------
|
|
|
968 -- Raise_Exception_Always --
|
|
|
969 ----------------------------
|
|
|
970
|
|
|
971 procedure Raise_Exception_Always
|
|
|
972 (E : Exception_Id;
|
|
|
973 Message : String := "")
|
|
|
974 is
|
|
|
975 X : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
976
|
|
|
977 begin
|
|
|
978 Exception_Data.Set_Exception_Msg (X, E, Message);
|
|
|
979
|
|
|
980 if not ZCX_By_Default then
|
|
|
981 Abort_Defer.all;
|
|
|
982 end if;
|
|
|
983
|
|
|
984 Complete_And_Propagate_Occurrence (X);
|
|
|
985 end Raise_Exception_Always;
|
|
|
986
|
|
|
987 ------------------------------
|
|
|
988 -- Raise_Exception_No_Defer --
|
|
|
989 ------------------------------
|
|
|
990
|
|
|
991 procedure Raise_Exception_No_Defer
|
|
|
992 (E : Exception_Id;
|
|
|
993 Message : String := "")
|
|
|
994 is
|
|
|
995 X : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
996
|
|
|
997 begin
|
|
|
998 Exception_Data.Set_Exception_Msg (X, E, Message);
|
|
|
999
|
|
|
1000 -- Do not call Abort_Defer.all, as specified by the spec
|
|
|
1001
|
|
|
1002 Complete_And_Propagate_Occurrence (X);
|
|
|
1003 end Raise_Exception_No_Defer;
|
|
|
1004
|
|
|
1005 -------------------------------------
|
|
|
1006 -- Raise_From_Controlled_Operation --
|
|
|
1007 -------------------------------------
|
|
|
1008
|
|
|
1009 procedure Raise_From_Controlled_Operation
|
|
|
1010 (X : Ada.Exceptions.Exception_Occurrence)
|
|
|
1011 is
|
|
|
1012 Prefix : constant String := "adjust/finalize raised ";
|
|
|
1013 Orig_Msg : constant String := Exception_Message (X);
|
|
|
1014 Orig_Prefix_Length : constant Natural :=
|
|
|
1015 Integer'Min (Prefix'Length, Orig_Msg'Length);
|
|
|
1016
|
|
|
1017 Orig_Prefix : String renames
|
|
|
1018 Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1);
|
|
|
1019
|
|
|
1020 begin
|
|
|
1021 -- Message already has the proper prefix, just re-raise
|
|
|
1022
|
|
|
1023 if Orig_Prefix = Prefix then
|
|
|
1024 Raise_Exception_No_Defer
|
|
|
1025 (E => Program_Error'Identity,
|
|
|
1026 Message => Orig_Msg);
|
|
|
1027
|
|
|
1028 else
|
|
|
1029 declare
|
|
|
1030 New_Msg : constant String := Prefix & Exception_Name (X);
|
|
|
1031
|
|
|
1032 begin
|
|
|
1033 -- No message present, just provide our own
|
|
|
1034
|
|
|
1035 if Orig_Msg = "" then
|
|
|
1036 Raise_Exception_No_Defer
|
|
|
1037 (E => Program_Error'Identity,
|
|
|
1038 Message => New_Msg);
|
|
|
1039
|
|
|
1040 -- Message present, add informational prefix
|
|
|
1041
|
|
|
1042 else
|
|
|
1043 Raise_Exception_No_Defer
|
|
|
1044 (E => Program_Error'Identity,
|
|
|
1045 Message => New_Msg & ": " & Orig_Msg);
|
|
|
1046 end if;
|
|
|
1047 end;
|
|
|
1048 end if;
|
|
|
1049 end Raise_From_Controlled_Operation;
|
|
|
1050
|
|
|
1051 -------------------------------------------
|
|
|
1052 -- Create_Occurrence_From_Signal_Handler --
|
|
|
1053 -------------------------------------------
|
|
|
1054
|
|
|
1055 function Create_Occurrence_From_Signal_Handler
|
|
|
1056 (E : Exception_Id;
|
|
|
1057 M : System.Address) return EOA
|
|
|
1058 is
|
|
|
1059 X : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
1060
|
|
|
1061 begin
|
|
|
1062 Exception_Data.Set_Exception_C_Msg (X, E, M);
|
|
|
1063
|
|
|
1064 if not ZCX_By_Default then
|
|
|
1065 Abort_Defer.all;
|
|
|
1066 end if;
|
|
|
1067
|
|
|
1068 Complete_Occurrence (X);
|
|
|
1069 return X;
|
|
|
1070 end Create_Occurrence_From_Signal_Handler;
|
|
|
1071
|
|
|
1072 ---------------------------------------------------
|
|
|
1073 -- Create_Machine_Occurrence_From_Signal_Handler --
|
|
|
1074 ---------------------------------------------------
|
|
|
1075
|
|
|
1076 function Create_Machine_Occurrence_From_Signal_Handler
|
|
|
1077 (E : Exception_Id;
|
|
|
1078 M : System.Address) return System.Address
|
|
|
1079 is
|
|
|
1080 begin
|
|
|
1081 return Create_Occurrence_From_Signal_Handler (E, M).Machine_Occurrence;
|
|
|
1082 end Create_Machine_Occurrence_From_Signal_Handler;
|
|
|
1083
|
|
|
1084 -------------------------------
|
|
|
1085 -- Raise_From_Signal_Handler --
|
|
|
1086 -------------------------------
|
|
|
1087
|
|
|
1088 procedure Raise_From_Signal_Handler
|
|
|
1089 (E : Exception_Id;
|
|
|
1090 M : System.Address)
|
|
|
1091 is
|
|
|
1092 begin
|
|
|
1093 Exception_Propagation.Propagate_Exception
|
|
131
|
1094 (Create_Occurrence_From_Signal_Handler (E, M).all);
|
|
111
|
1095 end Raise_From_Signal_Handler;
|
|
|
1096
|
|
|
1097 -------------------------
|
|
|
1098 -- Raise_Program_Error --
|
|
|
1099 -------------------------
|
|
|
1100
|
|
|
1101 procedure Raise_Program_Error
|
|
|
1102 (File : System.Address;
|
|
|
1103 Line : Integer)
|
|
|
1104 is
|
|
|
1105 begin
|
|
|
1106 Raise_With_Location_And_Msg (Program_Error_Def'Access, File, Line);
|
|
|
1107 end Raise_Program_Error;
|
|
|
1108
|
|
|
1109 -----------------------------
|
|
|
1110 -- Raise_Program_Error_Msg --
|
|
|
1111 -----------------------------
|
|
|
1112
|
|
|
1113 procedure Raise_Program_Error_Msg
|
|
|
1114 (File : System.Address;
|
|
|
1115 Line : Integer;
|
|
|
1116 Msg : System.Address)
|
|
|
1117 is
|
|
|
1118 begin
|
|
|
1119 Raise_With_Location_And_Msg
|
|
|
1120 (Program_Error_Def'Access, File, Line, M => Msg);
|
|
|
1121 end Raise_Program_Error_Msg;
|
|
|
1122
|
|
|
1123 -------------------------
|
|
|
1124 -- Raise_Storage_Error --
|
|
|
1125 -------------------------
|
|
|
1126
|
|
|
1127 procedure Raise_Storage_Error
|
|
|
1128 (File : System.Address;
|
|
|
1129 Line : Integer)
|
|
|
1130 is
|
|
|
1131 begin
|
|
|
1132 Raise_With_Location_And_Msg (Storage_Error_Def'Access, File, Line);
|
|
|
1133 end Raise_Storage_Error;
|
|
|
1134
|
|
|
1135 -----------------------------
|
|
|
1136 -- Raise_Storage_Error_Msg --
|
|
|
1137 -----------------------------
|
|
|
1138
|
|
|
1139 procedure Raise_Storage_Error_Msg
|
|
|
1140 (File : System.Address;
|
|
|
1141 Line : Integer;
|
|
|
1142 Msg : System.Address)
|
|
|
1143 is
|
|
|
1144 begin
|
|
|
1145 Raise_With_Location_And_Msg
|
|
|
1146 (Storage_Error_Def'Access, File, Line, M => Msg);
|
|
|
1147 end Raise_Storage_Error_Msg;
|
|
|
1148
|
|
|
1149 ---------------------------------
|
|
|
1150 -- Raise_With_Location_And_Msg --
|
|
|
1151 ---------------------------------
|
|
|
1152
|
|
|
1153 procedure Raise_With_Location_And_Msg
|
|
|
1154 (E : Exception_Id;
|
|
|
1155 F : System.Address;
|
|
|
1156 L : Integer;
|
|
|
1157 C : Integer := 0;
|
|
|
1158 M : System.Address := System.Null_Address)
|
|
|
1159 is
|
|
|
1160 X : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
1161 begin
|
|
|
1162 Exception_Data.Set_Exception_C_Msg (X, E, F, L, C, M);
|
|
|
1163
|
|
|
1164 if not ZCX_By_Default then
|
|
|
1165 Abort_Defer.all;
|
|
|
1166 end if;
|
|
|
1167
|
|
|
1168 Complete_And_Propagate_Occurrence (X);
|
|
|
1169 end Raise_With_Location_And_Msg;
|
|
|
1170
|
|
|
1171 --------------------
|
|
|
1172 -- Raise_With_Msg --
|
|
|
1173 --------------------
|
|
|
1174
|
|
|
1175 procedure Raise_With_Msg (E : Exception_Id) is
|
|
|
1176 Excep : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
1177 Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
|
|
|
1178 begin
|
|
|
1179 Excep.Exception_Raised := False;
|
|
|
1180 Excep.Id := E;
|
|
|
1181 Excep.Num_Tracebacks := 0;
|
|
|
1182 Excep.Pid := Local_Partition_ID;
|
|
|
1183
|
|
|
1184 -- Copy the message from the current exception
|
|
|
1185 -- Change the interface to be called with an occurrence ???
|
|
|
1186
|
|
|
1187 Excep.Msg_Length := Ex.Msg_Length;
|
|
|
1188 Excep.Msg (1 .. Excep.Msg_Length) := Ex.Msg (1 .. Ex.Msg_Length);
|
|
|
1189
|
|
|
1190 -- The following is a common pattern, should be abstracted
|
|
|
1191 -- into a procedure call ???
|
|
|
1192
|
|
|
1193 if not ZCX_By_Default then
|
|
|
1194 Abort_Defer.all;
|
|
|
1195 end if;
|
|
|
1196
|
|
|
1197 Complete_And_Propagate_Occurrence (Excep);
|
|
|
1198 end Raise_With_Msg;
|
|
|
1199
|
|
|
1200 -----------------------------------------
|
|
|
1201 -- Calls to Run-Time Check Subprograms --
|
|
|
1202 -----------------------------------------
|
|
|
1203
|
|
|
1204 procedure Rcheck_CE_Access_Check
|
|
|
1205 (File : System.Address; Line : Integer)
|
|
|
1206 is
|
|
|
1207 begin
|
|
|
1208 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_00'Address);
|
|
|
1209 end Rcheck_CE_Access_Check;
|
|
|
1210
|
|
|
1211 procedure Rcheck_CE_Null_Access_Parameter
|
|
|
1212 (File : System.Address; Line : Integer)
|
|
|
1213 is
|
|
|
1214 begin
|
|
|
1215 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_01'Address);
|
|
|
1216 end Rcheck_CE_Null_Access_Parameter;
|
|
|
1217
|
|
|
1218 procedure Rcheck_CE_Discriminant_Check
|
|
|
1219 (File : System.Address; Line : Integer)
|
|
|
1220 is
|
|
|
1221 begin
|
|
|
1222 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_02'Address);
|
|
|
1223 end Rcheck_CE_Discriminant_Check;
|
|
|
1224
|
|
|
1225 procedure Rcheck_CE_Divide_By_Zero
|
|
|
1226 (File : System.Address; Line : Integer)
|
|
|
1227 is
|
|
|
1228 begin
|
|
|
1229 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_03'Address);
|
|
|
1230 end Rcheck_CE_Divide_By_Zero;
|
|
|
1231
|
|
|
1232 procedure Rcheck_CE_Explicit_Raise
|
|
|
1233 (File : System.Address; Line : Integer)
|
|
|
1234 is
|
|
|
1235 begin
|
|
|
1236 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_04'Address);
|
|
|
1237 end Rcheck_CE_Explicit_Raise;
|
|
|
1238
|
|
|
1239 procedure Rcheck_CE_Index_Check
|
|
|
1240 (File : System.Address; Line : Integer)
|
|
|
1241 is
|
|
|
1242 begin
|
|
|
1243 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_05'Address);
|
|
|
1244 end Rcheck_CE_Index_Check;
|
|
|
1245
|
|
|
1246 procedure Rcheck_CE_Invalid_Data
|
|
|
1247 (File : System.Address; Line : Integer)
|
|
|
1248 is
|
|
|
1249 begin
|
|
|
1250 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_06'Address);
|
|
|
1251 end Rcheck_CE_Invalid_Data;
|
|
|
1252
|
|
|
1253 procedure Rcheck_CE_Length_Check
|
|
|
1254 (File : System.Address; Line : Integer)
|
|
|
1255 is
|
|
|
1256 begin
|
|
|
1257 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_07'Address);
|
|
|
1258 end Rcheck_CE_Length_Check;
|
|
|
1259
|
|
|
1260 procedure Rcheck_CE_Null_Exception_Id
|
|
|
1261 (File : System.Address; Line : Integer)
|
|
|
1262 is
|
|
|
1263 begin
|
|
|
1264 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_08'Address);
|
|
|
1265 end Rcheck_CE_Null_Exception_Id;
|
|
|
1266
|
|
|
1267 procedure Rcheck_CE_Null_Not_Allowed
|
|
|
1268 (File : System.Address; Line : Integer)
|
|
|
1269 is
|
|
|
1270 begin
|
|
|
1271 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_09'Address);
|
|
|
1272 end Rcheck_CE_Null_Not_Allowed;
|
|
|
1273
|
|
|
1274 procedure Rcheck_CE_Overflow_Check
|
|
|
1275 (File : System.Address; Line : Integer)
|
|
|
1276 is
|
|
|
1277 begin
|
|
|
1278 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_10'Address);
|
|
|
1279 end Rcheck_CE_Overflow_Check;
|
|
|
1280
|
|
|
1281 procedure Rcheck_CE_Partition_Check
|
|
|
1282 (File : System.Address; Line : Integer)
|
|
|
1283 is
|
|
|
1284 begin
|
|
|
1285 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_11'Address);
|
|
|
1286 end Rcheck_CE_Partition_Check;
|
|
|
1287
|
|
|
1288 procedure Rcheck_CE_Range_Check
|
|
|
1289 (File : System.Address; Line : Integer)
|
|
|
1290 is
|
|
|
1291 begin
|
|
|
1292 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_12'Address);
|
|
|
1293 end Rcheck_CE_Range_Check;
|
|
|
1294
|
|
|
1295 procedure Rcheck_CE_Tag_Check
|
|
|
1296 (File : System.Address; Line : Integer)
|
|
|
1297 is
|
|
|
1298 begin
|
|
|
1299 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address);
|
|
|
1300 end Rcheck_CE_Tag_Check;
|
|
|
1301
|
|
|
1302 procedure Rcheck_PE_Access_Before_Elaboration
|
|
|
1303 (File : System.Address; Line : Integer)
|
|
|
1304 is
|
|
|
1305 begin
|
|
|
1306 Raise_Program_Error_Msg (File, Line, Rmsg_14'Address);
|
|
|
1307 end Rcheck_PE_Access_Before_Elaboration;
|
|
|
1308
|
|
|
1309 procedure Rcheck_PE_Accessibility_Check
|
|
|
1310 (File : System.Address; Line : Integer)
|
|
|
1311 is
|
|
|
1312 begin
|
|
|
1313 Raise_Program_Error_Msg (File, Line, Rmsg_15'Address);
|
|
|
1314 end Rcheck_PE_Accessibility_Check;
|
|
|
1315
|
|
|
1316 procedure Rcheck_PE_Address_Of_Intrinsic
|
|
|
1317 (File : System.Address; Line : Integer)
|
|
|
1318 is
|
|
|
1319 begin
|
|
|
1320 Raise_Program_Error_Msg (File, Line, Rmsg_16'Address);
|
|
|
1321 end Rcheck_PE_Address_Of_Intrinsic;
|
|
|
1322
|
|
|
1323 procedure Rcheck_PE_Aliased_Parameters
|
|
|
1324 (File : System.Address; Line : Integer)
|
|
|
1325 is
|
|
|
1326 begin
|
|
|
1327 Raise_Program_Error_Msg (File, Line, Rmsg_17'Address);
|
|
|
1328 end Rcheck_PE_Aliased_Parameters;
|
|
|
1329
|
|
|
1330 procedure Rcheck_PE_All_Guards_Closed
|
|
|
1331 (File : System.Address; Line : Integer)
|
|
|
1332 is
|
|
|
1333 begin
|
|
|
1334 Raise_Program_Error_Msg (File, Line, Rmsg_18'Address);
|
|
|
1335 end Rcheck_PE_All_Guards_Closed;
|
|
|
1336
|
|
|
1337 procedure Rcheck_PE_Bad_Predicated_Generic_Type
|
|
|
1338 (File : System.Address; Line : Integer)
|
|
|
1339 is
|
|
|
1340 begin
|
|
|
1341 Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
|
|
|
1342 end Rcheck_PE_Bad_Predicated_Generic_Type;
|
|
|
1343
|
|
131
|
1344 procedure Rcheck_PE_Build_In_Place_Mismatch
|
|
|
1345 (File : System.Address; Line : Integer)
|
|
|
1346 is
|
|
|
1347 begin
|
|
|
1348 Raise_Program_Error_Msg (File, Line, Rmsg_37'Address);
|
|
|
1349 end Rcheck_PE_Build_In_Place_Mismatch;
|
|
|
1350
|
|
111
|
1351 procedure Rcheck_PE_Current_Task_In_Entry_Body
|
|
|
1352 (File : System.Address; Line : Integer)
|
|
|
1353 is
|
|
|
1354 begin
|
|
|
1355 Raise_Program_Error_Msg (File, Line, Rmsg_20'Address);
|
|
|
1356 end Rcheck_PE_Current_Task_In_Entry_Body;
|
|
|
1357
|
|
|
1358 procedure Rcheck_PE_Duplicated_Entry_Address
|
|
|
1359 (File : System.Address; Line : Integer)
|
|
|
1360 is
|
|
|
1361 begin
|
|
|
1362 Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
|
|
|
1363 end Rcheck_PE_Duplicated_Entry_Address;
|
|
|
1364
|
|
|
1365 procedure Rcheck_PE_Explicit_Raise
|
|
|
1366 (File : System.Address; Line : Integer)
|
|
|
1367 is
|
|
|
1368 begin
|
|
|
1369 Raise_Program_Error_Msg (File, Line, Rmsg_22'Address);
|
|
|
1370 end Rcheck_PE_Explicit_Raise;
|
|
|
1371
|
|
|
1372 procedure Rcheck_PE_Implicit_Return
|
|
|
1373 (File : System.Address; Line : Integer)
|
|
|
1374 is
|
|
|
1375 begin
|
|
|
1376 Raise_Program_Error_Msg (File, Line, Rmsg_24'Address);
|
|
|
1377 end Rcheck_PE_Implicit_Return;
|
|
|
1378
|
|
|
1379 procedure Rcheck_PE_Misaligned_Address_Value
|
|
|
1380 (File : System.Address; Line : Integer)
|
|
|
1381 is
|
|
|
1382 begin
|
|
|
1383 Raise_Program_Error_Msg (File, Line, Rmsg_25'Address);
|
|
|
1384 end Rcheck_PE_Misaligned_Address_Value;
|
|
|
1385
|
|
|
1386 procedure Rcheck_PE_Missing_Return
|
|
|
1387 (File : System.Address; Line : Integer)
|
|
|
1388 is
|
|
|
1389 begin
|
|
|
1390 Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
|
|
|
1391 end Rcheck_PE_Missing_Return;
|
|
|
1392
|
|
|
1393 procedure Rcheck_PE_Non_Transportable_Actual
|
|
|
1394 (File : System.Address; Line : Integer)
|
|
|
1395 is
|
|
|
1396 begin
|
|
|
1397 Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
|
|
|
1398 end Rcheck_PE_Non_Transportable_Actual;
|
|
|
1399
|
|
|
1400 procedure Rcheck_PE_Overlaid_Controlled_Object
|
|
|
1401 (File : System.Address; Line : Integer)
|
|
|
1402 is
|
|
|
1403 begin
|
|
|
1404 Raise_Program_Error_Msg (File, Line, Rmsg_27'Address);
|
|
|
1405 end Rcheck_PE_Overlaid_Controlled_Object;
|
|
|
1406
|
|
|
1407 procedure Rcheck_PE_Potentially_Blocking_Operation
|
|
|
1408 (File : System.Address; Line : Integer)
|
|
|
1409 is
|
|
|
1410 begin
|
|
|
1411 Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
|
|
|
1412 end Rcheck_PE_Potentially_Blocking_Operation;
|
|
|
1413
|
|
|
1414 procedure Rcheck_PE_Stream_Operation_Not_Allowed
|
|
|
1415 (File : System.Address; Line : Integer)
|
|
|
1416 is
|
|
|
1417 begin
|
|
|
1418 Raise_Program_Error_Msg (File, Line, Rmsg_36'Address);
|
|
|
1419 end Rcheck_PE_Stream_Operation_Not_Allowed;
|
|
|
1420
|
|
|
1421 procedure Rcheck_PE_Stubbed_Subprogram_Called
|
|
|
1422 (File : System.Address; Line : Integer)
|
|
|
1423 is
|
|
|
1424 begin
|
|
|
1425 Raise_Program_Error_Msg (File, Line, Rmsg_29'Address);
|
|
|
1426 end Rcheck_PE_Stubbed_Subprogram_Called;
|
|
|
1427
|
|
|
1428 procedure Rcheck_PE_Unchecked_Union_Restriction
|
|
|
1429 (File : System.Address; Line : Integer)
|
|
|
1430 is
|
|
|
1431 begin
|
|
|
1432 Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
|
|
|
1433 end Rcheck_PE_Unchecked_Union_Restriction;
|
|
|
1434
|
|
|
1435 procedure Rcheck_SE_Empty_Storage_Pool
|
|
|
1436 (File : System.Address; Line : Integer)
|
|
|
1437 is
|
|
|
1438 begin
|
|
|
1439 Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
|
|
|
1440 end Rcheck_SE_Empty_Storage_Pool;
|
|
|
1441
|
|
|
1442 procedure Rcheck_SE_Explicit_Raise
|
|
|
1443 (File : System.Address; Line : Integer)
|
|
|
1444 is
|
|
|
1445 begin
|
|
|
1446 Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
|
|
|
1447 end Rcheck_SE_Explicit_Raise;
|
|
|
1448
|
|
|
1449 procedure Rcheck_SE_Infinite_Recursion
|
|
|
1450 (File : System.Address; Line : Integer)
|
|
|
1451 is
|
|
|
1452 begin
|
|
|
1453 Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
|
|
|
1454 end Rcheck_SE_Infinite_Recursion;
|
|
|
1455
|
|
|
1456 procedure Rcheck_SE_Object_Too_Large
|
|
|
1457 (File : System.Address; Line : Integer)
|
|
|
1458 is
|
|
|
1459 begin
|
|
|
1460 Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address);
|
|
|
1461 end Rcheck_SE_Object_Too_Large;
|
|
|
1462
|
|
|
1463 procedure Rcheck_CE_Access_Check_Ext
|
|
|
1464 (File : System.Address; Line, Column : Integer)
|
|
|
1465 is
|
|
|
1466 begin
|
|
|
1467 Raise_Constraint_Error_Msg (File, Line, Column, Rmsg_00'Address);
|
|
|
1468 end Rcheck_CE_Access_Check_Ext;
|
|
|
1469
|
|
|
1470 procedure Rcheck_CE_Index_Check_Ext
|
|
|
1471 (File : System.Address; Line, Column, Index, First, Last : Integer)
|
|
|
1472 is
|
|
|
1473 Msg : constant String :=
|
|
|
1474 Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF
|
|
|
1475 & "index " & Image (Index) & " not in " & Image (First)
|
|
|
1476 & ".." & Image (Last) & ASCII.NUL;
|
|
|
1477 begin
|
|
|
1478 Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
|
|
|
1479 end Rcheck_CE_Index_Check_Ext;
|
|
|
1480
|
|
|
1481 procedure Rcheck_CE_Invalid_Data_Ext
|
|
|
1482 (File : System.Address; Line, Column, Index, First, Last : Integer)
|
|
|
1483 is
|
|
|
1484 Msg : constant String :=
|
|
|
1485 Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF
|
|
|
1486 & "value " & Image (Index) & " not in " & Image (First)
|
|
|
1487 & ".." & Image (Last) & ASCII.NUL;
|
|
|
1488 begin
|
|
|
1489 Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
|
|
|
1490 end Rcheck_CE_Invalid_Data_Ext;
|
|
|
1491
|
|
|
1492 procedure Rcheck_CE_Range_Check_Ext
|
|
|
1493 (File : System.Address; Line, Column, Index, First, Last : Integer)
|
|
|
1494 is
|
|
|
1495 Msg : constant String :=
|
|
|
1496 Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF
|
|
|
1497 & "value " & Image (Index) & " not in " & Image (First)
|
|
|
1498 & ".." & Image (Last) & ASCII.NUL;
|
|
|
1499 begin
|
|
|
1500 Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
|
|
|
1501 end Rcheck_CE_Range_Check_Ext;
|
|
|
1502
|
|
|
1503 procedure Rcheck_PE_Finalize_Raised_Exception
|
|
|
1504 (File : System.Address; Line : Integer)
|
|
|
1505 is
|
|
|
1506 X : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
1507
|
|
|
1508 begin
|
|
|
1509 -- This is "finalize/adjust raised exception". This subprogram is always
|
|
|
1510 -- called with abort deferred, unlike all other Rcheck_* subprograms, it
|
|
|
1511 -- needs to call Raise_Exception_No_Defer.
|
|
|
1512
|
|
|
1513 -- This is consistent with Raise_From_Controlled_Operation
|
|
|
1514
|
|
|
1515 Exception_Data.Set_Exception_C_Msg
|
|
|
1516 (X, Program_Error_Def'Access, File, Line, 0, Rmsg_23'Address);
|
|
|
1517 Complete_And_Propagate_Occurrence (X);
|
|
|
1518 end Rcheck_PE_Finalize_Raised_Exception;
|
|
|
1519
|
|
|
1520 -------------
|
|
|
1521 -- Reraise --
|
|
|
1522 -------------
|
|
|
1523
|
|
|
1524 procedure Reraise is
|
|
|
1525 Excep : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
1526 Saved_MO : constant System.Address := Excep.Machine_Occurrence;
|
|
|
1527
|
|
|
1528 begin
|
|
|
1529 if not ZCX_By_Default then
|
|
|
1530 Abort_Defer.all;
|
|
|
1531 end if;
|
|
|
1532
|
|
|
1533 Save_Occurrence (Excep.all, Get_Current_Excep.all.all);
|
|
|
1534 Excep.Machine_Occurrence := Saved_MO;
|
|
|
1535 Complete_And_Propagate_Occurrence (Excep);
|
|
|
1536 end Reraise;
|
|
|
1537
|
|
|
1538 --------------------------------------
|
|
|
1539 -- Reraise_Library_Exception_If_Any --
|
|
|
1540 --------------------------------------
|
|
|
1541
|
|
|
1542 procedure Reraise_Library_Exception_If_Any is
|
|
|
1543 LE : Exception_Occurrence;
|
|
|
1544
|
|
|
1545 begin
|
|
|
1546 if Library_Exception_Set then
|
|
|
1547 LE := Library_Exception;
|
|
|
1548
|
|
|
1549 if LE.Id = Null_Id then
|
|
|
1550 Raise_Exception_No_Defer
|
|
|
1551 (E => Program_Error'Identity,
|
|
|
1552 Message => "finalize/adjust raised exception");
|
|
|
1553 else
|
|
|
1554 Raise_From_Controlled_Operation (LE);
|
|
|
1555 end if;
|
|
|
1556 end if;
|
|
|
1557 end Reraise_Library_Exception_If_Any;
|
|
|
1558
|
|
|
1559 ------------------------
|
|
|
1560 -- Reraise_Occurrence --
|
|
|
1561 ------------------------
|
|
|
1562
|
|
|
1563 procedure Reraise_Occurrence (X : Exception_Occurrence) is
|
|
|
1564 begin
|
|
|
1565 if X.Id = null then
|
|
|
1566 return;
|
|
|
1567 else
|
|
|
1568 Reraise_Occurrence_Always (X);
|
|
|
1569 end if;
|
|
|
1570 end Reraise_Occurrence;
|
|
|
1571
|
|
|
1572 -------------------------------
|
|
|
1573 -- Reraise_Occurrence_Always --
|
|
|
1574 -------------------------------
|
|
|
1575
|
|
|
1576 procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
|
|
|
1577 begin
|
|
|
1578 if not ZCX_By_Default then
|
|
|
1579 Abort_Defer.all;
|
|
|
1580 end if;
|
|
|
1581
|
|
|
1582 Reraise_Occurrence_No_Defer (X);
|
|
|
1583 end Reraise_Occurrence_Always;
|
|
|
1584
|
|
|
1585 ---------------------------------
|
|
|
1586 -- Reraise_Occurrence_No_Defer --
|
|
|
1587 ---------------------------------
|
|
|
1588
|
|
|
1589 procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
|
|
|
1590 begin
|
|
131
|
1591 -- If we have a Machine_Occurrence at hand already, e.g. when we are
|
|
|
1592 -- reraising a foreign exception, just repropagate. Otherwise, e.g.
|
|
|
1593 -- when reraising a GNAT exception or an occurrence read back from a
|
|
|
1594 -- stream, set up a new occurrence with its own Machine block first.
|
|
|
1595
|
|
|
1596 if X.Machine_Occurrence /= System.Null_Address then
|
|
|
1597 Exception_Propagation.Propagate_Exception (X);
|
|
|
1598 else
|
|
|
1599 declare
|
|
|
1600 Excep : constant EOA
|
|
|
1601 := Exception_Propagation.Allocate_Occurrence;
|
|
|
1602 Saved_MO : constant System.Address := Excep.Machine_Occurrence;
|
|
|
1603 begin
|
|
|
1604 Save_Occurrence (Excep.all, X);
|
|
|
1605 Excep.Machine_Occurrence := Saved_MO;
|
|
|
1606 Complete_And_Propagate_Occurrence (Excep);
|
|
|
1607 end;
|
|
|
1608 end if;
|
|
111
|
1609 end Reraise_Occurrence_No_Defer;
|
|
|
1610
|
|
|
1611 ---------------------
|
|
|
1612 -- Save_Occurrence --
|
|
|
1613 ---------------------
|
|
|
1614
|
|
|
1615 procedure Save_Occurrence
|
|
|
1616 (Target : out Exception_Occurrence;
|
|
|
1617 Source : Exception_Occurrence)
|
|
|
1618 is
|
|
|
1619 begin
|
|
|
1620 -- As the machine occurrence might be a data that must be finalized
|
|
|
1621 -- (outside any Ada mechanism), do not copy it
|
|
|
1622
|
|
|
1623 Target.Id := Source.Id;
|
|
|
1624 Target.Machine_Occurrence := System.Null_Address;
|
|
|
1625 Target.Msg_Length := Source.Msg_Length;
|
|
|
1626 Target.Num_Tracebacks := Source.Num_Tracebacks;
|
|
145
|
1627 Target.Exception_Raised := Source.Exception_Raised;
|
|
111
|
1628 Target.Pid := Source.Pid;
|
|
|
1629
|
|
|
1630 Target.Msg (1 .. Target.Msg_Length) :=
|
|
|
1631 Source.Msg (1 .. Target.Msg_Length);
|
|
|
1632
|
|
|
1633 Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
|
|
|
1634 Source.Tracebacks (1 .. Target.Num_Tracebacks);
|
|
|
1635 end Save_Occurrence;
|
|
|
1636
|
|
|
1637 function Save_Occurrence (Source : Exception_Occurrence) return EOA is
|
|
|
1638 Target : constant EOA := new Exception_Occurrence;
|
|
|
1639 begin
|
|
|
1640 Save_Occurrence (Target.all, Source);
|
|
|
1641 return Target;
|
|
|
1642 end Save_Occurrence;
|
|
|
1643
|
|
|
1644 -------------------
|
|
|
1645 -- String_To_EId --
|
|
|
1646 -------------------
|
|
|
1647
|
|
|
1648 function String_To_EId (S : String) return Exception_Id
|
|
|
1649 renames Stream_Attributes.String_To_EId;
|
|
|
1650
|
|
|
1651 ------------------
|
|
|
1652 -- String_To_EO --
|
|
|
1653 ------------------
|
|
|
1654
|
|
|
1655 function String_To_EO (S : String) return Exception_Occurrence
|
|
|
1656 renames Stream_Attributes.String_To_EO;
|
|
|
1657
|
|
|
1658 ---------------
|
|
|
1659 -- To_Stderr --
|
|
|
1660 ---------------
|
|
|
1661
|
|
|
1662 procedure To_Stderr (C : Character) is
|
|
|
1663 procedure Put_Char_Stderr (C : Character);
|
|
|
1664 pragma Import (C, Put_Char_Stderr, "put_char_stderr");
|
|
|
1665 begin
|
|
|
1666 Put_Char_Stderr (C);
|
|
|
1667 end To_Stderr;
|
|
|
1668
|
|
|
1669 procedure To_Stderr (S : String) is
|
|
|
1670 begin
|
|
|
1671 for J in S'Range loop
|
|
|
1672 if S (J) /= ASCII.CR then
|
|
|
1673 To_Stderr (S (J));
|
|
|
1674 end if;
|
|
|
1675 end loop;
|
|
|
1676 end To_Stderr;
|
|
|
1677
|
|
|
1678 -------------------------
|
|
|
1679 -- Transfer_Occurrence --
|
|
|
1680 -------------------------
|
|
|
1681
|
|
|
1682 procedure Transfer_Occurrence
|
|
|
1683 (Target : Exception_Occurrence_Access;
|
|
|
1684 Source : Exception_Occurrence)
|
|
|
1685 is
|
|
|
1686 begin
|
|
|
1687 Save_Occurrence (Target.all, Source);
|
|
|
1688 end Transfer_Occurrence;
|
|
|
1689
|
|
|
1690 ------------------------
|
|
|
1691 -- Triggered_By_Abort --
|
|
|
1692 ------------------------
|
|
|
1693
|
|
|
1694 function Triggered_By_Abort return Boolean is
|
|
|
1695 Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
|
|
|
1696 begin
|
|
|
1697 return Ex /= null
|
|
|
1698 and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity;
|
|
|
1699 end Triggered_By_Abort;
|
|
|
1700
|
|
|
1701 -------------------------
|
|
|
1702 -- Wide_Exception_Name --
|
|
|
1703 -------------------------
|
|
|
1704
|
|
|
1705 WC_Encoding : Character;
|
|
|
1706 pragma Import (C, WC_Encoding, "__gl_wc_encoding");
|
|
|
1707 -- Encoding method for source, as exported by binder
|
|
|
1708
|
|
|
1709 function Wide_Exception_Name
|
|
|
1710 (Id : Exception_Id) return Wide_String
|
|
|
1711 is
|
|
|
1712 S : constant String := Exception_Name (Id);
|
|
|
1713 W : Wide_String (1 .. S'Length);
|
|
|
1714 L : Natural;
|
|
|
1715 begin
|
|
|
1716 String_To_Wide_String
|
|
|
1717 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
|
|
|
1718 return W (1 .. L);
|
|
|
1719 end Wide_Exception_Name;
|
|
|
1720
|
|
|
1721 function Wide_Exception_Name
|
|
|
1722 (X : Exception_Occurrence) return Wide_String
|
|
|
1723 is
|
|
|
1724 S : constant String := Exception_Name (X);
|
|
|
1725 W : Wide_String (1 .. S'Length);
|
|
|
1726 L : Natural;
|
|
|
1727 begin
|
|
|
1728 String_To_Wide_String
|
|
|
1729 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
|
|
|
1730 return W (1 .. L);
|
|
|
1731 end Wide_Exception_Name;
|
|
|
1732
|
|
|
1733 ----------------------------
|
|
|
1734 -- Wide_Wide_Exception_Name --
|
|
|
1735 -----------------------------
|
|
|
1736
|
|
|
1737 function Wide_Wide_Exception_Name
|
|
|
1738 (Id : Exception_Id) return Wide_Wide_String
|
|
|
1739 is
|
|
|
1740 S : constant String := Exception_Name (Id);
|
|
|
1741 W : Wide_Wide_String (1 .. S'Length);
|
|
|
1742 L : Natural;
|
|
|
1743 begin
|
|
|
1744 String_To_Wide_Wide_String
|
|
|
1745 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
|
|
|
1746 return W (1 .. L);
|
|
|
1747 end Wide_Wide_Exception_Name;
|
|
|
1748
|
|
|
1749 function Wide_Wide_Exception_Name
|
|
|
1750 (X : Exception_Occurrence) return Wide_Wide_String
|
|
|
1751 is
|
|
|
1752 S : constant String := Exception_Name (X);
|
|
|
1753 W : Wide_Wide_String (1 .. S'Length);
|
|
|
1754 L : Natural;
|
|
|
1755 begin
|
|
|
1756 String_To_Wide_Wide_String
|
|
|
1757 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
|
|
|
1758 return W (1 .. L);
|
|
|
1759 end Wide_Wide_Exception_Name;
|
|
|
1760
|
|
|
1761 --------------------------
|
|
|
1762 -- Code_Address_For_ZZZ --
|
|
|
1763 --------------------------
|
|
|
1764
|
|
|
1765 -- This function gives us the end of the PC range for addresses
|
|
|
1766 -- within the exception unit itself. We hope that gigi/gcc keeps all the
|
|
|
1767 -- procedures in their original order.
|
|
|
1768
|
|
|
1769 function Code_Address_For_ZZZ return System.Address is
|
|
|
1770 begin
|
|
|
1771 <<Start_Of_ZZZ>>
|
|
|
1772 return Start_Of_ZZZ'Address;
|
|
|
1773 end Code_Address_For_ZZZ;
|
|
|
1774
|
|
|
1775 end Ada.Exceptions;
|
