(* ERRORS.PAS -- handle errors
** Copyright (c) 1995,1996 Jochen Metzinger
**
** This program is free software; you can redistribute it and/or modify
** it under the terms of the GNU General Public License as published by
** the Free Software Foundation; either version 2, or (at your option)
** any later version.
**
** This program is distributed in the hope that it will be useful,
** but WITHOUT ANY WARRANTY; without even the implied warranty of
** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
** GNU General Public License for more details.
**
** You should have received a copy of the GNU General Public License
** along with this program; if not, write to the Free Software
** Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*)

UNIT errors;

INTERFACE

USES global;

VAR short_usage: STRING;
  (* short description of the program usage *)
 source: STRING;
  (* active part of the program *)

PROCEDURE message(msg: STRING);
(* print message *)

FUNCTION is_err: BOOLEAN;
(* test for an error *)

PROCEDURE error(msg: STRING);
(* set error condition *)

PROCEDURE err_recover;
(* print out error and continue *)

FUNCTION get_error: STRING;
(* return error and continue *)

PROCEDURE FATAL(msg: STRING);
(* print out error and stop program *)

PROCEDURE err_stop;
(* if is_err then FATAL() *)

IMPLEMENTATION

VAR err_msg: STRING;
     (* saved error message *)

FUNCTION is_err: BOOLEAN;
BEGIN
 is_err := (err_msg <> '');
END; (* is_err *)

PROCEDURE error(msg: STRING);
BEGIN
 err_msg := msg;
END; (* error *)

PROCEDURE message(msg: STRING);
BEGIN
 IF source <> '' THEN Write(source,': ');
 WriteLn(msg)
END; (* message *)

FUNCTION get_error: STRING;
BEGIN
 IF source = '' THEN
  get_error := 'ERROR: ' + err_msg
 ELSE
  get_error := source + ': ' + err_msg;
 err_msg := '';
END; (* get_error *)

PROCEDURE err_recover;
BEGIN
 WriteLn(get_error);
END; (* error_recover *)

PROCEDURE FATAL(msg: STRING);
BEGIN
 IF source = '' THEN
  Write('FATAL: ')
 ELSE
  Write(source,': ');
 WriteLn(msg);
 IF short_usage <> '' THEN
  WriteLn(short_usage);
 HALT(2);
END; (* FATAL *)

PROCEDURE err_stop;
BEGIN
 IF is_err THEN FATAL(err_msg);
END; (* error_stop *)

PROCEDURE ExitProcedure;
(* called after before terminating program *)
BEGIN
 (* normal termination? *)
 IF ErrorAddr = NIL THEN
  HALT(ExitCode);
 (* fatal run-time error *)
 IF source = '' THEN Write('FATAL: ') ELSE Write(source,': ');
 (* too few memory? *)
 IF ExitCode = 203 THEN BEGIN
  WriteLn('Heap overflow');
  HALT(4);
 END; (* if *)
 Write('INTERN [Run-time error ',ExitCode,' at ');
 WriteLn(HexStr(Seg(ErrorAddr^),4),':',HexStr(Ofs(ErrorAddr^),4),']');
 HALT(3);
END; (* ExitProcedure *)

BEGIN
 short_usage := '';
 source := '';
 err_msg := '';
 ExitProc := @ExitProcedure;
END. (* errors *)