1 (* RTExceptions.mod runtime exception handler routines.
3 Copyright (C) 2008-2024 Free Software Foundation, Inc.
4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
6 This file is part of GNU Modula-2.
8 GNU Modula-2 is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 GNU Modula-2 is distributed in the hope that it will be useful, but
14 WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
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/>. *)
27 IMPLEMENTATION MODULE RTExceptions
;
29 FROM ASCII
IMPORT nul
, nl
;
30 FROM StrLib
IMPORT StrLen
;
31 FROM Storage
IMPORT ALLOCATE
, DEALLOCATE
;
32 FROM SYSTEM
IMPORT ADR
, THROW
;
33 FROM libc
IMPORT write
, strlen
;
34 FROM M2RTS
IMPORT HALT, Halt
;
35 FROM SysExceptions
IMPORT InitExceptionHandlers
;
44 Handler
= POINTER TO RECORD
45 p
: ProcedureHandler
;
52 EHBlock
= POINTER TO RECORD
53 buffer
: ARRAY [0..MaxBuffer
] OF CHAR ;
59 PtrToChar
= POINTER TO CHAR ;
63 inException
: BOOLEAN ;
64 freeHandler
: Handler
;
66 currentEHB
: EHBlock
;
67 currentSource
: ADDRESS
;
71 SetExceptionSource - sets the current exception source to, source.
74 PROCEDURE SetExceptionSource (source
: ADDRESS
) ;
76 currentSource
:= source
77 END SetExceptionSource
;
81 GetExceptionSource - returns the current exception source.
84 PROCEDURE GetExceptionSource () : ADDRESS
;
87 END GetExceptionSource
;
91 ErrorString - writes a string to stderr.
94 PROCEDURE ErrorString (a
: ARRAY OF CHAR) ;
98 n
:= write(2, ADR(a
), StrLen(a
))
106 PROCEDURE findHandler (e
: EHBlock
; number
: CARDINAL) : Handler
;
110 h
:= e^.handlers^.right
;
111 WHILE (h#e^.handlers
) AND (number#h^.n
) DO
124 InvokeHandler - invokes the associated handler for the current
125 exception in the active EHB.
128 PROCEDURE InvokeHandler
<* noreturn
*> ;
132 h
:= findHandler (currentEHB
, currentEHB^.number
) ;
135 THROW (GetNumber (GetExceptionBlock ()))
144 DefaultErrorCatch - displays the current error message in
145 the current exception block and then
149 PROCEDURE DefaultErrorCatch
;
154 e
:= GetExceptionBlock() ;
155 n
:= write (2, GetTextBuffer (e
), strlen (GetTextBuffer (e
))) ;
157 END DefaultErrorCatch
;
161 DoThrow - throw the exception number in the exception block.
166 THROW (GetNumber (GetExceptionBlock ()))
171 BaseExceptionsThrow - configures the Modula-2 exceptions to call
172 THROW which in turn can be caught by an
173 exception block. If this is not called then
174 a Modula-2 exception will simply call an
175 error message routine and then HALT.
178 PROCEDURE BaseExceptionsThrow
;
180 i
: M2EXCEPTION.M2Exceptions
;
182 FOR i
:= MIN(M2EXCEPTION.M2Exceptions
) TO MAX(M2EXCEPTION.M2Exceptions
) DO
183 PushHandler (GetExceptionBlock (), VAL (CARDINAL, i
), DoThrow
)
185 END BaseExceptionsThrow
;
189 addChar - adds, ch, to the current exception handler text buffer
190 at index, i. The index in then incremented.
193 PROCEDURE addChar (ch
: CHAR; VAR i
: CARDINAL) ;
195 IF (i
<=MaxBuffer
) AND (currentEHB#
NIL)
197 currentEHB^.buffer
[i
] := ch
;
204 stripPath - returns the filename from the path.
207 PROCEDURE stripPath (s
: ADDRESS
) : ADDRESS
;
227 addFile - adds the filename determined by, s, however it strips
231 PROCEDURE addFile (s
: ADDRESS
; VAR i
: CARDINAL) ;
236 WHILE (p#
NIL) AND (p^#nul
) DO
244 addStr - adds a C string from address, s, into the current
248 PROCEDURE addStr (s
: ADDRESS
; VAR i
: CARDINAL) ;
253 WHILE (p#
NIL) AND (p^#nul
) DO
261 addNum - adds a number, n, to the current handler
265 PROCEDURE addNum (n
: CARDINAL; VAR i
: CARDINAL) ;
269 addChar(CHR(n
MOD 10 + ORD('0')), i
)
271 addNum(n
DIV 10, i
) ;
278 Raise - invoke the exception handler associated with, number,
279 in the active EHBlock. It keeps a record of the number
280 and message in the EHBlock for later use.
283 PROCEDURE Raise (number
: CARDINAL;
284 file
: ADDRESS
; line
: CARDINAL;
285 column
: CARDINAL; function
: ADDRESS
;
290 currentEHB^.number
:= number
;
302 addStr (function
, i
) ;
310 addStr (message
, i
) ;
318 SetExceptionBlock - sets, source, as the active EHB.
321 PROCEDURE SetExceptionBlock (source
: EHBlock
) ;
324 END SetExceptionBlock
;
328 GetExceptionBlock - returns the active EHB.
331 PROCEDURE GetExceptionBlock () : EHBlock
;
334 END GetExceptionBlock
;
338 GetTextBuffer - returns the address of the EHB buffer.
341 PROCEDURE GetTextBuffer (e
: EHBlock
) : ADDRESS
;
343 RETURN( ADR(e^.buffer
) )
348 GetTextBufferSize - return the size of the EHB text buffer.
351 PROCEDURE GetTextBufferSize (e
: EHBlock
) : CARDINAL ;
353 RETURN SIZE(e^.buffer
)
354 END GetTextBufferSize
;
358 GetNumber - return the exception number associated with,
362 PROCEDURE GetNumber (source
: EHBlock
) : CARDINAL ;
364 RETURN( source^.number
)
369 New - returns a new EHBlock.
372 PROCEDURE New () : EHBlock
;
381 freeEHB
:= freeEHB^.right
388 InitExceptionBlock - creates and returns a new exception block.
391 PROCEDURE InitExceptionBlock () : EHBlock
;
397 number
:= MAX(CARDINAL) ;
398 handlers
:= NewHandler() ; (* add the dummy onto the head *)
399 handlers^.right
:= handlers
;
400 handlers^.left
:= handlers
;
404 END InitExceptionBlock
;
408 KillExceptionBlock - destroys the EHB, e, and all its handlers.
411 PROCEDURE KillExceptionBlock (e
: EHBlock
) : EHBlock
;
413 e^.handlers
:= KillHandlers(e^.handlers
) ;
414 e^.right
:= freeEHB
;
417 END KillExceptionBlock
;
421 NewHandler - returns a new handler.
424 PROCEDURE NewHandler () : Handler
;
433 freeHandler
:= freeHandler^.right
440 KillHandler - returns, NIL, and places, h, onto the free list.
443 PROCEDURE KillHandler (h
: Handler
) : Handler
;
445 h^.right
:= freeHandler
;
452 KillHandlers - kills all handlers in the list.
455 PROCEDURE KillHandlers (h
: Handler
) : Handler
;
457 h^.left^.right
:= freeHandler
;
467 PROCEDURE InitHandler (h
: Handler
; l
, r
, s
: Handler
; number
: CARDINAL; proc
: ProcedureHandler
) : Handler
;
484 PROCEDURE SubHandler (h
: Handler
) ;
486 h^.right^.left
:= h^.left
;
487 h^.left^.right
:= h^.right
;
492 AddHandler - add, e, to the end of the list of handlers.
495 PROCEDURE AddHandler (e
: EHBlock
; h
: Handler
) ;
497 h^.right
:= e^.handlers
;
498 h^.left
:= e^.handlers^.left
;
499 e^.handlers^.left^.right
:= h
;
500 e^.handlers^.left
:= h
505 PushHandler - install a handler in EHB, e.
508 PROCEDURE PushHandler (e
: EHBlock
; number
: CARDINAL; p
: ProcedureHandler
) ;
512 h
:= findHandler(e
, number
) ;
515 i
:= InitHandler(NewHandler(), NIL, NIL, NIL, number
, p
) ;
519 (* stack it onto a new handler *)
520 i
:= InitHandler(NewHandler(), NIL, NIL, h
, number
, p
) ;
522 (* add new handler *)
528 PopHandler - removes the handler associated with, number, from
532 PROCEDURE PopHandler (e
: EHBlock
; number
: CARDINAL) ;
536 h
:= findHandler(e
, number
) ;
543 AddHandler(e
, h^.stack
)
551 IsInExceptionState - returns TRUE if the program is currently
552 in the exception state.
555 PROCEDURE IsInExceptionState () : BOOLEAN ;
557 RETURN( inException
)
558 END IsInExceptionState
;
562 SetExceptionState - returns the current exception state and
563 then sets the current exception state to,
567 PROCEDURE SetExceptionState (to
: BOOLEAN) : BOOLEAN ;
574 END SetExceptionState
;
578 SwitchExceptionState - assigns, from, with the current exception
579 state and then assigns the current exception
583 PROCEDURE SwitchExceptionState (VAR from
: BOOLEAN; to
: BOOLEAN) ;
585 from
:= inException
;
587 END SwitchExceptionState
;
591 GetBaseExceptionBlock - returns the initial language exception block
595 PROCEDURE GetBaseExceptionBlock () : EHBlock
;
599 Halt('currentEHB has not been initialized yet',
600 __FILE__
, __FUNCTION__
, __LINE__
)
604 END GetBaseExceptionBlock
;
608 indexf - raise an index out of bounds exception.
611 PROCEDURE indexf (a
: ADDRESS
) ;
613 Raise(ORD(M2EXCEPTION.indexException
),
614 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
615 ADR("array index out of bounds"))
620 range - raise an assignment out of range exception.
623 PROCEDURE range (a
: ADDRESS
) ;
625 Raise(ORD(M2EXCEPTION.rangeException
),
626 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
627 ADR("assignment out of range"))
632 casef - raise a case selector out of range exception.
635 PROCEDURE casef (a
: ADDRESS
) ;
637 Raise(ORD(M2EXCEPTION.caseSelectException
),
638 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
639 ADR("case selector out of range"))
644 invalidloc - raise an invalid location exception.
647 PROCEDURE invalidloc (a
: ADDRESS
) ;
649 Raise(ORD(M2EXCEPTION.invalidLocation
),
650 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
651 ADR("invalid address referenced"))
656 function - raise a ... function ... exception. --fixme-- what does this exception catch?
659 PROCEDURE function (a
: ADDRESS
) ;
661 Raise(ORD(M2EXCEPTION.functionException
),
662 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
663 ADR("... function ... ")) (* --fixme-- what has happened ? *)
668 wholevalue - raise an illegal whole value exception.
671 PROCEDURE wholevalue (a
: ADDRESS
) ;
673 Raise(ORD(M2EXCEPTION.wholeValueException
),
674 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
675 ADR("illegal whole value exception"))
680 wholediv - raise a division by zero exception.
683 PROCEDURE wholediv (a
: ADDRESS
) ;
685 Raise(ORD(M2EXCEPTION.wholeDivException
),
686 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
687 ADR("illegal whole value exception"))
692 realvalue - raise an illegal real value exception.
695 PROCEDURE realvalue (a
: ADDRESS
) ;
697 Raise(ORD(M2EXCEPTION.realValueException
),
698 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
699 ADR("illegal real value exception"))
704 realdiv - raise a division by zero in a real number exception.
707 PROCEDURE realdiv (a
: ADDRESS
) ;
709 Raise(ORD(M2EXCEPTION.realDivException
),
710 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
711 ADR("real number division by zero exception"))
716 complexvalue - raise an illegal complex value exception.
719 PROCEDURE complexvalue (a
: ADDRESS
) ;
721 Raise(ORD(M2EXCEPTION.complexValueException
),
722 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
723 ADR("illegal complex value exception"))
728 complexdiv - raise a division by zero in a complex number exception.
731 PROCEDURE complexdiv (a
: ADDRESS
) ;
733 Raise(ORD(M2EXCEPTION.complexDivException
),
734 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
735 ADR("complex number division by zero exception"))
740 protection - raise a protection exception.
743 PROCEDURE protection (a
: ADDRESS
) ;
745 Raise(ORD(M2EXCEPTION.protException
),
746 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
747 ADR("protection exception"))
752 systemf - raise a system exception.
755 PROCEDURE systemf (a
: ADDRESS
) ;
757 Raise(ORD(M2EXCEPTION.sysException
),
758 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
759 ADR("system exception"))
764 coroutine - raise a coroutine exception.
767 PROCEDURE coroutine (a
: ADDRESS
) ;
769 Raise(ORD(M2EXCEPTION.coException
),
770 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
771 ADR("coroutine exception"))
776 exception - raise a exception exception.
779 PROCEDURE exception (a
: ADDRESS
) ;
781 Raise(ORD(M2EXCEPTION.exException
),
782 ADR(__FILE__
), __LINE__
, __COLUMN__
, ADR(__FUNCTION__
),
783 ADR("exception exception"))
788 Init - initialises this module.
793 inException
:= FALSE ;
796 currentEHB
:= InitExceptionBlock() ;
797 currentSource
:= NIL ;
798 BaseExceptionsThrow
;
799 InitExceptionHandlers(indexf
, range
, casef
, invalidloc
,
800 function
, wholevalue
, wholediv
,
801 realvalue
, realdiv
, complexvalue
,
802 complexdiv
, protection
, systemf
,
803 coroutine
, exception
)
808 TidyUp - deallocate memory used by this module.
818 currentEHB
:= KillExceptionBlock(currentEHB
)
820 WHILE freeHandler#
NIL DO
822 freeHandler
:= freeHandler^.right
;
827 freeEHB
:= freeEHB^.right
;