runtime/src/common/RTHooks.m3


Copyright (C) 1994, Digital Equipment Corp.
 Many of the routines in the RTHooks interface are exported directly
   by other modules of the runtime:
 

          PushEFrame, PopEFrame   are in Thread
          LockMutex, UnlockMutex  are in Thread
          Allocate*, Dispose*     are in RTAllocator

UNSAFE MODULE RTHooks;

IMPORT RT0, RTException, RTMisc, Text, Word;

<*UNUSED*> VAR copyright := ARRAY [0..36] OF TEXT {
  "              SRC Modula-3 Non-commercial License",
  "",
  "SRC Modula-3 is distributed by Digital Equipment Corporation ('DIGITAL'),",
  "a corporation of the Commonwealth of Massachusetts.  DIGITAL hereby grants",
  "to you a non-transferable, non-exclusive, royalty free worldwide license",
  "to use, copy, modify, prepare integrated and derivative works of and",
  "distribute SRC Modula-3 for non-commercial purposes, subject to your",
  "agreement to the following terms and conditions:",
  "",
  "  - The SRC Modula-3 Non-commercial License shall be included in the code",
  "    and must be retained in all copies of SRC Modula-3 (full or partial;",
  "    original, modified, derivative, or otherwise):",
  "",
  "  - You acquire no ownership right, title, or interest in SRC Modula-3",
  "    except as provided herein.",
  "",
  "  - You agree to make available to DIGITAL all improvements,",
  "    enhancements, extensions, and modifications to SRC Modula-3 which",
  "    are made by you or your sublicensees and distributed to others and",
  "    hereby grant to DIGITAL an irrevocable, fully paid, worldwide, and",
  "    non-exclusive license under your intellectual property rights,",
  "    including patent and copyright, to use and sublicense, without",
  "  limititation, these modifications.",
  "",
  "  - SRC Modula-3 is a research work which is provided 'as is',",
  "    and  DIGITAL disclaims all warranties",
  "    with regard to this software, including all implied warranties of",
  "    merchantability and fitness of purpose.  In no event shall DIGITAL be",
  "    liable for any special, direct, indirect, or consequential damages or",
  "    any damages whatsoever resulting from loss of use, data or profits,",
  "    whether in an action of contract, negligence or other tortious action,",
  "    arising out of or in connection with the use or performance of this",
  "    software. ",
  "",
  "",
  "              Copyright (C) 1990 Digital Equipment Corporation",
  "                       All Rights Reserved"
   };
----------------------------------------------------------------- RAISE ---

PROCEDURE Raise (exception: ADDRESS;  arg: ADDRESS) RAISES ANY =
  BEGIN
    RTException.Raise (exception, arg);
  END Raise;

PROCEDURE ResumeRaise (info: ADDRESS) RAISES ANY =
  TYPE Info = UNTRACED REF RECORD exception, arg: ADDRESS END;
  VAR p := LOOPHOLE (info, Info);
  BEGIN
    RTException.ResumeRaise (p.exception, p.arg);
  END ResumeRaise;
----------------------------------------------- builtin TEXT operations ---

PROCEDURE Concat (a, b: TEXT): TEXT =
  BEGIN
    RETURN Text.Cat (a, b);
  END Concat;
-------------------------------------------------------- runtime errors ---

CONST
  msgs = ARRAY [0..9] OF TEXT {
    (* 0 *) "ASSERT failed",
    (* 1 *) "Value out of range",
    (* 2 *) "Subscript out of range",
    (* 3 *) "Incompatible array shapes",
    (* 4 *) "Attempt to dereference NIL",
    (* 5 *) "NARROW failed",
    (* 6 *) "Function did not return a value",
    (* 7 *) "Unhandled value in CASE statement",
    (* 8 *) "Unhandled type in TYPECASE statement",
    (* 9 *) "Stack overflow"
  };

PROCEDURE ReportFault (module: ADDRESS(*RT0.ModulePtr*);  info: INTEGER)=
  VAR
    line : INTEGER       := Word.RightShift (info, 4);
    code : INTEGER       := Word.And (info, 16_f);
    mi   : RT0.ModulePtr := module;
    file : RT0.String    := NIL;
    msg  : TEXT          := "bad error code!";
  BEGIN
    IF (0 <= code) AND (code <= LAST (msgs)) THEN msg := msgs[code]; END;
    IF (mi # NIL) THEN file := mi.file; END;
    RTMisc.FatalErrorS (file, line, msg);
  END ReportFault;

BEGIN
END RTHooks.