Copyright (C) 1994, Digital Equipment Corp.
UNSAFE MODULE----------------------------------------------------------- diagnostics ---RTException EXPORTSRTException ,RTExRep ; IMPORT RT0, RTMisc, RTIO, RTParams, RTOS; IMPORT Thread, ThreadF, M3toC, Ctypes, Csetjmp; VAR DEBUG := FALSE; dump_enabled := FALSE; TYPE FinallyProc = PROCEDURE () RAISES ANY; EXCEPTION OUCH; (* to keep the compiler from complaining *) PROCEDURERaise (en: ExceptionName; arg: ExceptionArg) RAISES ANY = VAR f := LOOPHOLE(ThreadF.GetCurrentHandlers(), Frame); ex: ExceptionList; BEGIN IF DEBUG THEN RTIO.PutText ("---> RAISE:"); RTIO.PutText (" en="); RTIO.PutAddr (en); RTIO.PutText (" "); RTIO.PutString (en^); RTIO.PutText (" arg="); RTIO.PutAddr (arg); RTIO.PutText ("\n"); DumpStack (); END; LOOP IF (f = NIL) THEN NoHandler (en, raises := FALSE); END; CASE f.class OF | ORD (ScopeKind.Except) => ex := LOOPHOLE (f, PF1).handles; WHILE (ex^ # NIL) DO IF (ex^ = en) THEN ResumeRaise (en, arg) END; INC (ex, ADRSIZE (ex^)); END; | ORD (ScopeKind.ExceptElse) => (* 's' is a TRY-EXCEPT-ELSE frame => go for it *) ResumeRaise (en, arg); | ORD (ScopeKind.Finally), ORD (ScopeKind.FinallyProc), ORD (ScopeKind.Lock) => (* ignore for this pass *) | ORD (ScopeKind.Raises) => (* check that this procedure does indeed raise 'en' *) ex := LOOPHOLE (f, PF3).raises; IF ex = NIL THEN NoHandler (en); END; LOOP IF (ex^ = NIL) THEN NoHandler (en) END; IF (ex^ = en) THEN (* ok, it passes *) EXIT END; INC (ex, ADRSIZE (ex^)); END; | ORD (ScopeKind.RaisesNone) => NoHandler (en); ELSE BadStack (); END; f := f.next; (* try the previous frame *) END; END Raise; PROCEDUREResumeRaise (en: ExceptionName; arg: ExceptionArg) RAISES ANY = VAR f := LOOPHOLE(ThreadF.GetCurrentHandlers(), Frame); ex: ExceptionList; BEGIN IF DEBUG THEN RTIO.PutText ("---> RERAISE:"); RTIO.PutText (" en="); RTIO.PutAddr (en); RTIO.PutText (" "); RTIO.PutString (en^); RTIO.PutText (" arg="); RTIO.PutAddr (arg); RTIO.PutText ("\n"); DumpStack (); END; LOOP IF (f = NIL) THEN BadStack (); END; CASE f.class OF | ORD (ScopeKind.ExceptElse), ORD (ScopeKind.Finally) => InvokeHandler (f, en, arg); | ORD (ScopeKind.Except) => ex := LOOPHOLE (f, PF1).handles; WHILE (ex^ # NIL) DO IF (ex^ = en) THEN InvokeHandler (f, en, arg) END; INC (ex, ADRSIZE (ex^)); END; | ORD (ScopeKind.FinallyProc) => InvokeFinallyHandler (f, en, arg); | ORD (ScopeKind.Lock) => ReleaseLock (f); | ORD (ScopeKind.Raises) => (* already checked during the first pass *) ELSE BadStack (); END; ThreadF.SetCurrentHandlers (f.next); (* cut to the new handler *) f := f.next; (* try the previous frame *) END; END ResumeRaise; PROCEDUREInvokeHandler (f: Frame; en: ExceptionName; arg: ExceptionArg) RAISES ANY = VAR p := LOOPHOLE (f, PF1); BEGIN IF DEBUG THEN RTIO.PutText ("--> INVOKE HANDLER:"); RTIO.PutText (" en="); RTIO.PutAddr (en); RTIO.PutText (" "); RTIO.PutString (en^); RTIO.PutText (" arg="); RTIO.PutAddr (arg); RTIO.PutText (" frame="); RTIO.PutAddr (f); RTIO.PutText (" class="); RTIO.PutInt (f.class); RTIO.PutText ("\n"); RTIO.Flush (); END; ThreadF.SetCurrentHandlers (f.next); (* cut to the new handler *) p.exception := en; (* record the exception *) p.arg := arg; (* and it argument *) Csetjmp.ulongjmp (p.jmpbuf, 1); (* and jump... *) RAISE OUCH; END InvokeHandler; PROCEDUREInvokeFinallyHandler (f: Frame; en: ExceptionName; arg: ExceptionArg) RAISES ANY = VAR p := LOOPHOLE (f, PF2); cl: RT0.ProcedureClosure; BEGIN IF DEBUG THEN RTIO.PutText ("--> INVOKE FINALLY HANDLER:"); RTIO.PutText (" en="); RTIO.PutAddr (en); RTIO.PutText (" "); RTIO.PutString (en^); RTIO.PutText (" arg="); RTIO.PutAddr (arg); RTIO.PutText (" frame="); RTIO.PutAddr (f); RTIO.PutText (" class="); RTIO.PutInt (f.class); RTIO.PutText ("\n"); RTIO.Flush (); END; (* build a nested procedure closure *) cl.marker := RT0.ClosureMarker; cl.proc := p.handler; cl.frame := p.frame; ThreadF.SetCurrentHandlers (f.next); (* cut to the new handler *) CallProc (LOOPHOLE (ADR (cl), FinallyProc)); END InvokeFinallyHandler; PROCEDURECallProc (p: FinallyProc) RAISES ANY = (* we need to fool the compiler into generating a call to a nested procedure... *) BEGIN p (); END CallProc; PROCEDUREReleaseLock (f: Frame) = VAR p := LOOPHOLE (f, PF4); BEGIN IF DEBUG THEN RTIO.PutText ("--> UNLOCK:"); RTIO.PutText (" frame="); RTIO.PutAddr (p); RTIO.PutText (" mutex="); RTIO.PutAddr (LOOPHOLE (p.mutex, ADDRESS)); RTIO.PutText ("\n"); RTIO.Flush (); END; ThreadF.SetCurrentHandlers (f.next); (* cut to the new handler *) Thread.Release (p.mutex); (* and release the lock *) END ReleaseLock; PROCEDURENoHandler (en: ExceptionName; raises := TRUE) = VAR nm := EName (en); BEGIN IF (raises) THEN RTMisc.FatalError (NIL, 0, "Exception \"", nm, "\" not in RAISES list"); ELSE RTMisc.FatalError (NIL, 0, "Unhandled exception \"", nm, "\""); END; END NoHandler; PROCEDUREBadStack () = BEGIN RTMisc.FatalError (NIL, 0, "corrupt exception stack"); END BadStack;
PROCEDURESanityCheck () = CONST Min_SK = ORD (FIRST (ScopeKind)); CONST Max_SK = ORD (LAST (ScopeKind)); VAR f := LOOPHOLE(ThreadF.GetCurrentHandlers(), Frame); VAR i: INTEGER; BEGIN WHILE (f # NIL) DO i := f.class; IF (i < Min_SK) OR (Max_SK < i) THEN BadStack () END; f := f.next; END; END SanityCheck; PROCEDUREDumpStack () = VAR f := LOOPHOLE(ThreadF.GetCurrentHandlers(), Frame); BEGIN IF NOT DEBUG AND NOT dump_enabled THEN RETURN; END; RTOS.LockHeap (); (* disable thread switching... (you wish!) *) RTIO.PutText ("------------------ EXCEPTION HANDLER STACK ---------------------\n"); WHILE (f # NIL) DO RTIO.PutAddr (f); CASE f.class OF | ORD (ScopeKind.Except) => RTIO.PutText (" TRY-EXCEPT "); DumpHandles (LOOPHOLE (f, PF1).handles); | ORD (ScopeKind.ExceptElse) => RTIO.PutText (" TRY-EXCEPT-ELSE "); | ORD (ScopeKind.Finally) => RTIO.PutText (" TRY-FINALLY "); | ORD (ScopeKind.FinallyProc) => VAR x := LOOPHOLE (f, PF2); BEGIN RTIO.PutText (" TRY-FINALLY proc = "); RTIO.PutAddr (x.handler); RTIO.PutText (" frame = "); RTIO.PutAddr (x.frame); END; | ORD (ScopeKind.Raises) => RTIO.PutText (" RAISES "); DumpHandles (LOOPHOLE (f, PF3).raises); | ORD (ScopeKind.RaisesNone) => RTIO.PutText (" RAISES {}"); | ORD (ScopeKind.Lock) => VAR x := LOOPHOLE (f, PF4); BEGIN RTIO.PutText (" LOCK mutex = "); RTIO.PutAddr (LOOPHOLE (x.mutex, ADDRESS)); END; ELSE RTIO.PutText (" *** BAD EXCEPTION RECORD, class = "); RTIO.PutInt (f.class); RTIO.PutText (" ***\n"); EXIT; END; RTIO.PutText ("\n"); f := f.next; END; RTIO.PutText ("----------------------------------------------------------------\n"); RTIO.Flush (); RTOS.UnlockHeap (); END DumpStack; PROCEDUREDumpHandles (x: ExceptionList) = VAR first := TRUE; en: ExceptionName; BEGIN RTIO.PutText (" {"); IF (x # NIL) THEN WHILE (x^ # NIL) DO IF (NOT first) THEN RTIO.PutText (", "); END; first := FALSE; en := x^; RTIO.PutString (en^); INC (x, ADRSIZE (x^)); END; END; RTIO.PutText ("}"); END DumpHandles; PROCEDUREEName (en: ExceptionName): TEXT = BEGIN RETURN M3toC.StoT (LOOPHOLE (en^, Ctypes.char_star)); END EName; BEGIN dump_enabled := RTParams.IsPresent ("stackdump"); EVAL SanityCheck; (* avoid the unused warning *) END RTException.