IMPLEMENTATION MODULE M2RTS ;


FROM libc IMPORT abort, exit, write ;
FROM NumberIO IMPORT CardToStr ;
FROM StrLib IMPORT StrCopy, StrLen ;
FROM SYSTEM IMPORT ADDRESS, ADR ;
FROM ASCII IMPORT nl, nul ;


CONST
   Max       =   10 ;
   Foobar    =   20 ;
   Min       =   Max+Foobar ;
   MaxLength = 4096 ;

TYPE
   mytype = ARRAY [0..Max] OF CARDINAL ;

VAR
   Ptr      : CARDINAL ;
   List     : ARRAY [0..Max] OF PROC ;
   ExitValue: INTEGER ;
   CallExit : BOOLEAN ;
   Testing  : mytype ;
   Works    : ARRAY [0..Max+Min] OF PROC ;


(*
   Terminate - calls each installed termination procedure in turn.
*)

PROCEDURE Terminate ;
CONST
   FooBa = 12 ;
VAR
   i: CARDINAL ;
   t: ARRAY [0..FooBa] OF CARDINAL ;
BEGIN
   i := 0 ;
   WHILE i<Ptr DO
      List[i] ;
      INC(i)
   END
END Terminate ;


(*
   HALT - terminate the current program calling creating a core dump.
          The procedure Terminate is called before the core dump is
          created.
*)

PROCEDURE HALT ;
CONST
   FooBa = 3+3 ;
BEGIN
   Terminate ;
   IF CallExit
   THEN
      exit(ExitValue)
   ELSE
      abort
   END
END HALT ;


(*
   ErrorString - writes a string to stderr.
*)

PROCEDURE ErrorString (a: ARRAY OF CHAR) ;
VAR
   buf: ARRAY [0..MaxLength] OF CHAR ;
   n  : INTEGER ;
BEGIN
   StrCopy(a, buf) ;
   n := write(2, ADR(buf), StrLen(buf))
END ErrorString ;


(*
   ErrorMessage - emits an error message to the stderr
*)

PROCEDURE ErrorMessage (message: ARRAY OF CHAR; file: ARRAY OF CHAR; line: CARDINAL) ;
VAR
   LineNo: ARRAY [0..10] OF CHAR ;
BEGIN
   ErrorString(file) ; ErrorString(':') ;
   CardToStr(line, 0, LineNo) ;
   ErrorString(LineNo) ; ErrorString(':') ;
   ErrorString(message) ;
   LineNo[0] := nl ; LineNo[1] := nul ;
   ErrorString(LineNo) ;
   exit(1)
END ErrorMessage ;


(*
   SubrangeAssignmentError - part of the runtime checking, called if a
                             subrange variable is just about to be assigned an illegal value.
*)

PROCEDURE SubrangeAssignmentError (file: ARRAY OF CHAR; line: CARDINAL) ;
BEGIN
   ErrorMessage('variable exceeds subrange', file, line)
END SubrangeAssignmentError ;


(*
   ArraySubscriptError -  part of the runtime checking, called if an
                          array indice is out of range.
*)

PROCEDURE ArraySubscriptError (file: ARRAY OF CHAR; line: CARDINAL) ;
BEGIN
   ErrorMessage('array index out of bounds', file, line)
END ArraySubscriptError ;


(*
   FunctionReturnError -  part of the runtime checking, called if a
                          function exits without a RETURN statement.
*)

PROCEDURE FunctionReturnError (file: ARRAY OF CHAR; line: CARDINAL) ;
BEGIN
   ErrorMessage('function is attempting to exit without a formal RETURN statement', file, line)
END FunctionReturnError ;


(*
   ExitOnHalt - if HALT is executed then call exit with the exit code, e.
*)

PROCEDURE ExitOnHalt (e: INTEGER) ;
BEGIN
   ExitValue := e ;
   CallExit := TRUE
END ExitOnHalt ;


(*
   InstallTerminationProcedure - installs a procedure, p, which will
                                 be called when the procedure Terminate
                                 is invoked.
*)

PROCEDURE InstallTerminationProcedure (p: PROC) ;
BEGIN
   List[Ptr] := p ;
   INC(Ptr)
END InstallTerminationProcedure ;


BEGIN
   Ptr := 0 ;
   ExitValue := 0 ;
   CallExit := FALSE   (* default by calling abort *)
END M2RTS.