(* Copyright (C) 1990, Digital Equipment Corporation *) (* All rights reserved. *) (* See the file COPYRIGHT for a full description. *) (* Last modified on Mon Sep 14 11:14:36 PDT 1992 by rustan *) (* modified on Thu Apr 9 09:50:51 PDT 1992 by kalsow *) (* modified on Mon Nov 18 15:26:22 PST 1991 by muller *) UNSAFE MODULE RTMisc; (* Note, the procedures in this module may be called before all initializations have been done. Hence, this module cannot rely on anything that cannot be initialized statically by the C compiler. *) (******** KRML IMPORT RTHeap, RTProc, Unix, Usignal, Uprocess, Cstring; ****** KRML *) IMPORT SmallIO; IMPORT RTRegisters, RTMain; (*-------------------------------- program startup/shutdown -----------------*) (************************************************** KRML REVEAL Exitor = BRANDED "RTMisc.Exitor" REF RECORD proc: PROCEDURE (n: INTEGER) RAISES ANY; next: Exitor; END; VAR exitors: Exitor := NIL; PROCEDURE RegisterExitor (p: PROCEDURE (n: INTEGER) RAISES ANY): Exitor = VAR e := NEW (Exitor, proc := p, next := exitors); BEGIN exitors := e; RETURN (e); END RegisterExitor; PROCEDURE UnregisterExitor (e: Exitor) = BEGIN e.proc := NIL; END UnregisterExitor; PROCEDURE InvokeExitors () = VAR tmp: Exitor; BEGIN (* run the registered "exit" routines *) WHILE exitors # NIL DO (* to ensure progress, remove an element from the list before invoking it *) tmp := exitors; exitors := exitors.next; IF (tmp.proc # NIL) THEN <*FATAL ANY*> BEGIN tmp.proc (-1); END; END; END; END InvokeExitors; PROCEDURE Exit (n: INTEGER) = BEGIN InvokeExitors (); EVAL Unix.exit (n); END Exit; (*------------------------------- byte copying ------------------------------*) PROCEDURE Copy (src, dest: ADDRESS; len: INTEGER) = BEGIN EVAL Cstring.memcpy (dest, src, len); END Copy; PROCEDURE Zero (dest: ADDRESS; len: INTEGER) = BEGIN EVAL Cstring.memset (dest, 0, len); END Zero; (*------------------------------- rounded arithmetic ------------------------*) PROCEDURE Align (a: ADDRESS; y: INTEGER): ADDRESS = BEGIN RETURN LOOPHOLE (Upper (LOOPHOLE (a, INTEGER), y), ADDRESS); END Align; PROCEDURE Upper (x, y: INTEGER): INTEGER = BEGIN RETURN ((x + y - 1) DIV y) * y; END Upper; ************************************************ KRML *) (*------------------------------- runtime error reporting -------------------*) (********************************************************************* KRML PROCEDURE FatalError (file: TEXT; line: INTEGER; msgA, msgB, msgC: TEXT := NIL) = BEGIN SmallIO.PutText ( (*** KRML SmallIO.stderr, ***) "\n\n***\n*** runtime error:\n*** "); IF (msgA # NIL) THEN SmallIO.PutText ( (*KRML SmallIO.stderr, *) msgA) END; IF (msgB # NIL) THEN SmallIO.PutText ( (*KRML SmallIO.stderr, *) msgB) END; IF (msgC # NIL) THEN SmallIO.PutText ( (*KRML SmallIO.stderr, *) msgC) END; IF (file # NIL) THEN SmallIO.PutText ( (** KRML SmallIO.stderr, **) "\n*** file \""); SmallIO.PutText ( (** KRML SmallIO.stderr, **) file); SmallIO.PutText ( (** KRML SmallIO.stderr, **) "\", line "); SmallIO.PutInt ( (** KRML SmallIO.stderr, **) line); END; SmallIO.PutText ( (*** KRML SmallIO.stderr, ***) "\n***\n\n"); Crash (); END FatalError; PROCEDURE FatalErrorI (msg: TEXT := NIL; i: INTEGER) = BEGIN SmallIO.PutText ( (*** KRML SmallIO.stderr, ***) "\n\n***\n*** runtime error:\n*** "); SmallIO.PutText ( (*** KRML SmallIO.stderr, ***) msg); SmallIO.PutInt ( (*** KRML SmallIO.stderr, ***) i); SmallIO.PutText ( (*** KRML SmallIO.stderr, ***) "\n***\n\n"); Crash (); END FatalErrorI; PROCEDURE FatalErrorPC (pc: INTEGER; msgA, msgB, msgC: TEXT := NIL) = (*************************** KRML VAR proc: RTProc.Proc; name: RTProc.Name; ************************** KRML *) BEGIN SmallIO.PutText ( (*** KRML SmallIO.stderr, ***) "\n\n***\n*** runtime error:\n*** "); IF (msgA # NIL) THEN SmallIO.PutText ( (*KRML SmallIO.stderr, *) msgA) END; IF (msgB # NIL) THEN SmallIO.PutText ( (*KRML SmallIO.stderr, *) msgB) END; IF (msgC # NIL) THEN SmallIO.PutText ( (*KRML SmallIO.stderr, *) msgC) END; IF (pc # 0) THEN SmallIO.PutText ( (*** KRML SmallIO.stderr, ***) "\n*** pc = "); SmallIO.PutHexa ( (*** KRML SmallIO.stderr, ***) pc); (*************************** KRML RTProc.FromPC (LOOPHOLE (pc, ADDRESS), proc, name); IF (name # NIL) THEN SmallIO.PutText (SmallIO.stderr, " = "); SmallIO.PutChars (SmallIO.stderr, name, Cstring.strlen (name)); pc := pc - LOOPHOLE (proc, INTEGER); IF (pc # 0) THEN SmallIO.PutText (SmallIO.stderr, " + "); SmallIO.PutHexa (SmallIO.stderr, pc); END; END; ************************** KRML *) END; SmallIO.PutText ( (*** SmallIO.stderr, ***) "\n***\n\n"); Crash (); END FatalErrorPC; ******************************************************************* KRML *) PROCEDURE Crash () = BEGIN SmallIO.Flush ( (*** KRML SmallIO.stderr ***) ); (*************** KRML (* run the registered "exit" routines *) InvokeExitors (); (* crash *) EVAL Usignal.kill (Uprocess.getpid (), Usignal.SIGQUIT); LOOP END; (* wait for the signal to arrive *) ************* KRML *) (* new KRML *) (* this jumps to the end of the program *) RTRegisters.Restore( RTMain.rootRegs ); (* Note, the following assert, if ever executed, will not cause the program to terminate, since the call will eventually end up in this procedure! But then again, control shouldn't get here... *) <* ASSERT FALSE *> (* end KRML *) END Crash; (* KRML. The following calls to FatalErrorStr used to be calls to FatalError *) (* KRML. Most all of the following procedures used to have a signature of: ( file: TEXT; line: INTEGER ) *) PROCEDURE AssertFault() = BEGIN FaultToHost( 100 ) END AssertFault; PROCEDURE ReturnFault() = BEGIN FaultToHost( 101 ) END ReturnFault; PROCEDURE CaseFault() = BEGIN FaultToHost( 102 ) END CaseFault; PROCEDURE TypecaseFault() = BEGIN FaultToHost( 103 ) END TypecaseFault; PROCEDURE RangeFault() = BEGIN FaultToHost( 104 ) END RangeFault; (****************************************************************** KRML PROCEDURE SubscriptFault (file: TEXT; line: INTEGER) = BEGIN FatalError (file, line, "Subscript out of range"); END SubscriptFault; **************************************************************** KRML *) PROCEDURE NarrowFault() = BEGIN FaultToHost( 105 ) END NarrowFault; (****************************************************************** KRML PROCEDURE NilFault (file: TEXT; line: INTEGER) = BEGIN FatalError (file, line, "attempt to dereference NIL"); END NilFault; **************************************************************** KRML *) (* new KRML *) PROCEDURE NilFault() = BEGIN FaultToHost( 106 ) END NilFault; (* end KRML *) PROCEDURE RaisesFault (ex_name: TEXT) = BEGIN FatalErrorStr ("Exception \"", ex_name, "\" not in RAISES list"); END RaisesFault; PROCEDURE HandlerFault (ex_name: TEXT) = BEGIN FatalErrorStr ("Unhandled exception \"", ex_name, "\""); END HandlerFault; PROCEDURE StackOverflow() = BEGIN FaultToHost( 107 ) END StackOverflow; (* new KRML *) CONST ErrorStrings = ARRAY Fault OF TEXT { "Deadlock", "Join called twice", "Space left for heap too small", "Out of memory", "Negative array size", "Corrupt exception stack" }; PROCEDURE FatalError( f: Fault ) = BEGIN FaultToHost( 200 + ORD( f )) END FatalError; (**** FatalErrorStr( ErrorStrings[ f ] ) END FatalError; ****) PROCEDURE FatalErrorStr( msgA, msgB, msgC: TEXT := NIL ) = BEGIN SmallIO.PutText ( "\n\n***\n*** runtime error:\n*** " ); IF msgA # NIL THEN SmallIO.PutText( msgA ) END; IF msgB # NIL THEN SmallIO.PutText( msgB ) END; IF msgC # NIL THEN SmallIO.PutText( msgC ) END; SmallIO.PutText ( "\n***\n\n" ); Crash () END FatalErrorStr; (* end KRML *) BEGIN (*********** KRML EVAL RTHeap.Allocate; (*an attempt to force the allocator to be initialized*) ********* KRML *) END RTMisc.