{
Copyright (C) 1997-99 Free Software Foundation, Inc.

Authors: Frank Heckenbach <frank@pascal.gnu.de>
         Jukka Virtanen <jtv@hut.fi>

Error handling routines

This file is part of GNU Pascal Library. The GNU Pascal Library is free
software; you can redistribute it and/or modify it under the terms of
the GNU Library General Public License as published by the Free Software
Foundation; either version 2 of the License, or (at your option) any
later version.

The GNU Pascal Library 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
Library General Public License for more details.

You should have received a copy of the GNU Library General Public
License along with the GNU Pascal Library; see the file COPYING.LIB.  If
not, write to the Free Software Foundation, Inc., 675 Mass Ave,
Cambridge, MA 02139, USA.
}

unit Err;

interface

uses GPC, Internal;

var
  { BP compatible InOutRes variable }
  GPC_InOutRes : asmname '_p_inoutres' Integer;
  GPC_InOutRes : Integer = 0;

  { CString parameter to some error messages, NOT the text of the error
    message (this can be obtained with GetErrorMessage) }
  GPC_InOutResStr : asmname '_p_inoutres_str' CString;
  GPC_InOutResStr : CString = nil;

  { Error number (after runtime error) or exit status (after Halt) or
    0 (during program run and after succesful termination). }
  ExitCode : asmname '_p_exitcode' Integer;
  ExitCode : Integer = 0;

  { Non-nil after runtime error, nil otherwise. Does not give the actual
    address of the code where the error occurred. }
  ErrorAddr : asmname '_p_erroraddr' Pointer;
  ErrorAddr : Pointer = nil;

function  GetErrorMessage                 (n : Integer) : CString;                   asmname '_p_errmsg';
function  GetCheckErrorMessage            (n : Integer; Format : CString) : CString; asmname '_p_check_errmsg';
procedure StartRuntimeMessage;                                                       asmname '_p_start_message';
procedure StartInternalError;                                                        asmname '_p_start_internal_error';
procedure EndRuntimeError                 (n : Integer);                             asmname '_p_end_error';
function  StartRuntimeWarning : Boolean;                                             asmname '_p_start_warning';
procedure EndRuntimeWarning;                                                         asmname '_p_end_warning';
procedure RuntimeError                    (n : Integer);                             asmname '_p_error';
procedure RuntimeErrorInteger             (n : Integer; i : MedInt);                 asmname '_p_error_integer';
procedure RuntimeErrorCString             (n : Integer; s : CString);                asmname '_p_error_string';
procedure InternalError                   (n : Integer);                             asmname '_p_internal_error';
procedure InternalErrorInteger            (n : Integer; i : MedInt);                 asmname '_p_internal_error_integer';
procedure RuntimeWarning                  (Message : CString);                       asmname '_p_warning';
procedure RuntimeWarningInteger           (Message : CString; i : MedInt);           asmname '_p_warning_integer';
procedure RuntimeWarningCString           (Message : CString; s : CString);          asmname '_p_warning_string';
procedure GPC_RunError                    (n : Integer);                             asmname '_p_runerror';
procedure StartTempIOError;                                                          asmname '_p_start_temp_io_error';
function  EndTempIOError : Integer;                                                  asmname '_p_end_temp_io_error';
procedure IOError                         (n : Integer);                             asmname '_p_io_error';
procedure IOErrorCString                  (n : Integer; s : CString);                asmname '_p_io_error_string';
function  GPC_IOResult : Integer;                                                    asmname '_p_ioresult';
function  GetIOErrorMessage : CString;                                               asmname '_p_get_io_error_message';
procedure CheckInOutRes;                                                             asmname '_p_check_inoutres';
procedure GPC_Halt (aExitCode : Integer);                                            asmname '_p_halt';
procedure HeapWarning                     (s : CString);                             asmname '_p_heap_warning';
procedure PrintMessage (Message : CString; n : Integer; Warning : Boolean);          asmname '_p_prmessage';

implementation

{$B-,I-,X+}

procedure FPrintF (Dest : CFilePtr; Format : CString; ...); C;
procedure SPrintF (Dest, Format : CString; ...); C;

const
  ErrorMessages : array [1 .. 180] of record
    Number  : Integer;
    Message : CString
  end =
  (
    { Leave the `Byte' range free for program specific errors. }

    { Unsorted errors }
    (300, 'an error which was reported during compilation'),
    (301, 'array index out of bounds'),
    (302, 'variant access error'),
    (303, 'attempt to dereference nil pointer'),
    (304, 'attempt to dereference undefined pointer'),
    (307, 'scalar parameter out of bounds'),
    (308, 'set parameter out of bounds'),
    (317, 'input data out of bounds'),
    (318, 'output data out of bounds'),
    (323, 'dispose applied to nil pointer'),
    (324, 'dispose applied to undefined pointer'),
    (326, 'index parameter of `Pack'' out of bounds'),
    (329, 'index parameter of `Unpack'' out of bounds'),
    (332, 'argument of `Sqr'' out of range'),
    (337, 'argument of `Chr'' out of range'),
    (338, 'argument of `Succ'' out of range'),
    (339, 'argument of `Pred'' out of range'),
    (343, 'attempt to use an undefined value'),
    (348, 'function undefined upon return'),
    (349, 'value to be assigned is out of bounds'),
    (351, '`Case'' selector value matches no case constant'),
    (352, 'initial value of `For'' control variable out of range'),
    (353, 'final value of `For'' control variable out of range'),
    (354, 'integer data out of range'),
    (355, 'index type of conformant array out of range'),
    (380, 'call to predefined procedure `Bug'''),
    (381, 'assert failure'),
    (382, 'attempt to use undefined value of ordinal type'),
    (383, 'attempt to use undefined value of set type'),
    (384, 'attempt to use undefined value of integer type'),
    (385, 'attempt to use undefined value of real type'),
    (386, 'attempt to use undefined value of pointer type'),
    (390, 'no temporary file name found'),

    { I/O errors (range 400 .. 699) that are handled via _p_inoutres }

    { I/O errors: File and general I/O errors }
    { For errors raised with IOERROR_FILE, the "%s" will be replaced by
      "file `foo.bar'" for external files or "internal file `foo'" for
      internal files, so don't include "file" in the error message }
  { (400, 'cannot open %s'), }
    (401, 'cannot open directory `%s'''),
    (402, '`Bind'' applied to non-bindable %s'),
    (403, '`Binding'' applied to non-bindable %s'),
    (404, '`Unbind'' applied to non-bindable %s'),
  { (405, 'writing past current size of random access %s'), }
    (406, 'attempt to read past end of random access %s'),
    (407, '%s has not been opened'),
  { (408, 'attempt to test `Eof'' for random access %s'),
    (409, '%s is not opened for `Seek'' operations'), }
    (410, 'attempt to access elements before beginning of random access %s'),
    (411, 'attempt to modify read only %s'),
  { (412, 'random access %s back stepping failed'), }
    (413, 'error in `BlockRead'' from %s'),
    (414, 'cannot read all the data from %s in `BlockRead'''),
    (415, 'error in `BlockWrite'' to %s'),
    (416, 'cannot write all the data to %s in `BlockWrite'''),
    (417, 'ftell failed in `FilePos'' for %s'),
    (419, 'cannot prompt user for external name bindings for %s'),
    (420, 'cannot query user for external name bindings for %s'),
    (421, 'EOT character given for query of name for %s'),
    (422, 'cannot write to read only %s'),
    (423, 'ftruncate failed when re-opening %s with `Rewrite'''),
    (424, 'invalid string length in `Bind'' of %s'),
    (425, 'truncation failed for %s'),
    (426, '`SeekRead'' to write only %s'),
    (427, '`SeekRead'' seek failed on %s'),
    (428, '`SeekRead'' failed to reset position of %s'),
    (429, '`SeekWrite'' seek failed on %s'),
    (430, '`SeekUpdate'' to read only %s'),
    (431, '`SeekUpdate'' seek failed on %s'),
    (432, '`SeekUpdate'' failed to reset position of %s'),
    (433, '`Update'' failed to reset the position of %s'),
    (434, '`Put'' failed on %s - nothing written'),
    (435, '`Put'' failed on %s - partial record written'),
    (436, '`Reset'', `SeekUpdate'' or `SeekRead'' to nonexistent %s'),
    (437, 'cannot append implicit end of line character to %s in append mode'),
    (438, '`Truncate'' or `DefineSize'' applied to read only %s'),
    (439, '`Update'' with an undefined buffer in %s'),
    (440, 'reference to buffer variable of %s with undefined value'),
    (441, 'file already bound to `%s'''),
    (442, '%s cannot be opened for reading'),
    (443, '%s cannot be opened for writing'),
    (444, '%s cannot be opened for updating'),
    (445, '%s cannot be extended'),
    (446, 'cannot stat %s'),
    (450, '%s is not open for writing'),
  { (451, '%s must be opened before writing'), }
    (452, '%s is not open for reading'),
  { (453, '%s must be opened before reading'), }
    (454, 'attempt to read past end of %s'),
    (455, '`Eof'' tested for unopened %s'),
    (456, '`Eoln'' tested for unopened %s'),
    (457, '`Eoln'' tested for %s when `Eof'' is true'),
    (458, '`Eoln'' applied to a non-text %s'),
  { (460, '%s not found'),
    (461, '%s cannot be accessed'),
    (462, 'attempt to open %s as external'),
    (463, '%s is write protected'), }
    (464, 'error when reading from %s'),
    (465, 'cannot read all the data from %s'),
    (466, 'error when writing to %s'),
    (467, 'cannot write all the data to %s'),
    (468, 'cannot erase %s'),
    (469, '`Erase'': external file `%s'' has no external name'),
    (470, 'cannot erase opened %s'),
    (471, '`Erase'': %s does not exist'),
    (472, 'permission denied to erase %s'),
    (473, '`Erase'': cannot erase directory `%s'''),
    (474, 'I/O error when trying to erase %s'),
    (475, 'cannot rename %s'),
    (476, '`Rename'': external file `%s'' has no external name'),
    (477, 'cannot rename opened %s'),
    (478, '`Rename'': %s does not exist'),
    (479, 'permission denied to rename %s'),
    (480, '`Rename'': cannot overwrite directory `%s'''),
    (481, 'I/O error when trying to rename %s'),
    (482, '`Rename'': cannot overwrite file `%s'''),
    (483, 'cannot change to directory `%s'''),
    (484, 'cannot make directory `%s'''),
    (485, 'cannot remove directory `%s'''),
    (486, '`SetFTime'': file `%s'' has no external name'),
    (487, 'cannot set time for %s'),
    (488, '`Execute'': cannot execute program'),
    (489, '`StatFS'': function not supported'),
    (490, 'cannot stat file system `%s'''),

    { I/O errors: Read errors }
    (550, 'attempt to read past end of string in `ReadStr'''),
    (551, 'digit expected after sign'),
    (552, 'sign or digit expected'),
    (553, 'overflow while reading integer'),
    (554, 'digit expected after decimal point'),
    (555, 'digit expected while reading exponent'),
    (556, 'exponent out of range'),
    (557, 'digit expected after `$'' in integer constant'),
    (558, 'digit expected after `#'' in integer constant'),
    (559, 'only one base specifier allowed in integer constant'),
    (560, 'base out of range (2..36)'),
    (561, 'invalid digit'),
    (562, 'digit or `.'' expected after sign'),
    (563, 'overflow while reading real number'),
    (564, 'underflow while reading real number'),
    (565, 'extra characters after number in `Val'''), { only used internally }

    { I/O errors: Write errors }
    (580, 'fixed field width cannot be negative'),
    (581, 'fixed real fraction field width cannot be negative'),
    (582, 'attempt to write past end of string in `WriteStr'''),

    { I/O errors: Application of direct access routines to non-direct files.
      They can be warnings or errors, depending on _p_force_direct_files }
    (590, 'direct access routine `GetSize'' applied to non-direct %s'),
    (591, 'direct access routine `SeekRead'' applied to non-direct %s'),
    (592, 'direct access routine `SeekWrite'' applied to non-direct %s'),
    (593, 'direct access routine `SeekUpdate'' applied to non-direct %s'),
    (594, 'direct access routine `Empty'' applied to non-direct %s'),
    (595, 'direct access routine `Update'' applied to non-direct %s'),
    (596, 'direct access routine `Position'' applied to non-direct %s'),

    { I/O errors: device specific errors }
    (600, 'cannot create pipe to `%s'''),
    (610, 'printer can only be opened for writing'),

    { Mathematical errors }
    (700, 'overflow in exponentiation'),
    (701, 'in `x pow y'', x must be >= 0 if y < 0 and y is not an integer'),
    (703, 'executed `x pow y'' when x is zero and y < 0'),
    (704, 'cannot take `Arg'' of zero'),
    (706, 'executed `x pow y'' when complex x is zero and y < 0'),
    (707, 'argument of `Ln'' is <= 0'),
    (708, 'argument of `Sqrt'' is < 0'),
    (709, 'significancy lost in `Cos'' - result set to zero'),
    (710, 'significancy lost in `Sin'' - result set to zero'),
    (711, 'floating point division by zero'),
    (712, 'integer division by 0'),
    (713, 'integer overflow'),
    (714, 'second operand of `mod'' is <= 0'),
    (715, 'floating point overflow'),
    (716, 'floating point underflow'),

    { Time and date errors }
    (750, 'invalid date supplied to library function `Date'''),
    (751, 'invalid time supplied to library function `Time'''),

    { String errors (except string I/O errors) }
    (800, 'string too long in `Insert'''),
    (801, 'substring cannot start from positions less than 1'),
    (802, 'substring length cannot be negative'),
    (803, 'substring must terminate before end of string'),
    (806, 'string too long'),

    { Memory management errors }
    (850, 'stack overflow'),
    (851, 'heap overflow'),
    (852, 'cannot release object at address $%lx'),
    (853, 'out of heap when allocating %ld bytes'),
    (854, 'attempt to use disposed pointer'),
    (855, 'attempt to use disposed object'),

    { Internal errors }
    (900, 'compiler calls `Readln'' incorrectly'),
    (901, 'compiler calls `Writeln'' incorrectly'),
    (902, 'unknown code in `Read'''),
    (903, 'unknown code in `ReadStr'''),
    (904, 'unknown code in `Write'''),
    (905, 'unknown code in `WriteStr'''),
    (906, 'unknown string code in `WriteStr'''),
    (907, 'string length cannot be negative'),
    (908, 'incorrect reading of a string'),
    (909, 'unknown string function called'),
    (910, 'read buffer underflow');
    (914, '_p_initfdr has not been called for file'),
    (921, 'unknown mode in _p_open'),
    (922, 'undocumented error code %ld in exponentiation'),
    (925, 'file has no internal name')
  );

var
  TempIOErrorFlag : Boolean = False;
  TempInOutRes : Integer = 0;

function GetErrorMessage (n : Integer) : CString;
var i : Integer;
begin
  for i := Low (ErrorMessages) to High (ErrorMessages) do
    if ErrorMessages [i].Number = n then return ErrorMessages [i].Message;
  GetErrorMessage := 'internal error: unknown error code'
end;

function GetCheckErrorMessage (n : Integer; Format : CString) : CString;
var
  Msg : CString;
  Buf : array [0 .. 10] of Char;
  i, j : Integer;
begin
  Msg := GetErrorMessage (n);
  i := 0;
  j := 0;
  while Msg [j] <> #0 do
    begin
      if Msg [j] = '%' then
        begin
          Inc (j);
          Buf [i] := Msg [j];
          if i < High (Buf) then Inc (i)
        end;
      Inc (j)
    end;
  Buf [i] := #0;
  if (Buf [0] = #0) or (StrCmp (Buf, Format) = 0)
    then GetCheckErrorMessage := Msg
    else GetCheckErrorMessage := 'internal error: error handling was called incorrectly'
end;

procedure StartRuntimeMessage;
begin
  FlushAllFiles (True);
  FPrintF (GetFile (StdErr), '%s: ', CParameters^[0])
end;

procedure StartInternalError;
begin
  StartRuntimeMessage;
  FPrintF (GetFile (StdErr), 'internal error: ')
end;

procedure EndRuntimeError (n : Integer);
begin
  FPrintF (GetFile (StdErr), ' (error #%d)' + NewLine, n);
  ExitCode := n;
  ErrorAddr := Pointer ($deadbeef); (* @@ Should get the address of the caller,
    but that's probably impossible to do in a portable way *)
  ExitProgram (n)
end;

function StartRuntimeWarning = Result : Boolean;
begin
  Result := (RTSWarnFlag <> 0) or (RTSDebugFlag <> 0);
  if Result then
    begin
      StartRuntimeMessage;
      FPrintF (GetFile (StdErr), 'warning: ')
    end
end;

procedure EndRuntimeWarning;
begin
  FPrintF (GetFile (StdErr), NewLine)
end;

procedure RuntimeError (n : Integer);
begin
  StartRuntimeMessage;
  FPrintF (GetFile (StdErr), GetCheckErrorMessage (n, ''));
  EndRuntimeError (n)
end;

procedure RuntimeErrorInteger (n : Integer; i : MedInt);
begin
  StartRuntimeMessage;
  FPrintF (GetFile (StdErr), GetCheckErrorMessage (n, 'l'), i);
  EndRuntimeError (n)
end;

procedure RuntimeErrorCString (n : Integer; s : CString);
begin
  StartRuntimeMessage;
  FPrintF (GetFile (StdErr), GetCheckErrorMessage (n, 's'), s);
  EndRuntimeError (n)
end;

procedure InternalError (n : Integer);
begin
  StartInternalError;
  FPrintF (GetFile (StdErr), GetCheckErrorMessage (n, ''));
  EndRuntimeError (n)
end;

procedure InternalErrorInteger (n : Integer; i : MedInt);
begin
  StartInternalError;
  FPrintF (GetFile (StdErr), GetCheckErrorMessage (n, 'l'), i);
  EndRuntimeError (n)
end;

procedure RuntimeWarning (Message : CString);
begin
  if StartRuntimeWarning then
    begin
      FPrintF (GetFile (StdErr), Message);
      EndRuntimeWarning
    end
end;

procedure RuntimeWarningInteger (Message : CString; i : MedInt);
begin
  if StartRuntimeWarning then
    begin
      FPrintF (GetFile (StdErr), Message, i);
      EndRuntimeWarning
    end
end;

procedure RuntimeWarningCString (Message : CString; s : CString);
begin
  if StartRuntimeWarning then
    begin
      FPrintF (GetFile (StdErr), Message, s);
      EndRuntimeWarning
    end
end;

procedure GPC_RunError (n : Integer);
begin
  StartRuntimeMessage;
  FPrintF (GetFile (StdErr), 'runtime error');
  EndRuntimeError (n)
end;

procedure StartTempIOError;
begin
  TempInOutRes := GPC_IOResult;
  TempIOErrorFlag := True
end;

function EndTempIOError : Integer;
begin
  EndTempIOError := IOResult;
  GPC_InOutRes := TempInOutRes;
  TempIOErrorFlag := False
end;

procedure IOError (n : Integer);
begin
  GPC_InOutRes := n;
  if not TempIOErrorFlag then
    begin
      if GPC_InOutResStr <> nil then Dispose (GPC_InOutResStr);
      GPC_InOutResStr := nil
    end
end;

procedure IOErrorCString (n : Integer; s : CString);
begin
  GPC_InOutRes := n;
  if not TempIOErrorFlag then
    begin
      if GPC_InOutResStr <> nil then Dispose (GPC_InOutResStr);
      GPC_InOutResStr := StrDup (s)
    end
end;

(*@@maur3.pas inline*) function GPC_IOResult : Integer;
begin
  GPC_IOResult := GPC_InOutRes;
  GPC_InOutRes := 0
end;

function GetIOErrorMessage : CString;
var
  Buf : static CString = nil;
  Msg : CString;
begin
  if GPC_InOutResStr <> nil
    then
      begin
        Msg := GetCheckErrorMessage (GPC_IOResult, 's');
        if Buf <> nil then Dispose (Buf);
        GetMem (Buf, StrLen (Msg) + StrLen (GPC_InOutResStr));
        SPrintF (Buf, Msg, GPC_InOutResStr);
        GetIOErrorMessage := Buf
      end
    else GetIOErrorMessage := GetCheckErrorMessage (GPC_IOResult, '')
end;

procedure CheckInOutRes;
var Temp : Integer;
begin
  Temp := GPC_IOResult;
  if Temp <> 0 then
    if GPC_InOutResStr <> nil
      then RuntimeErrorCString (Temp, GPC_InOutResStr)
      else RuntimeError (Temp)
end;

procedure GPC_Halt (aExitCode : Integer);
begin
  ExitCode := aExitCode;
  ErrorAddr := nil;
  ExitProgram (aExitCode)
end;

procedure HeapWarning (s : CString);
begin
  RuntimeWarningCString ('heap warning: %s', s)
end;

procedure PrintMessage (Message : CString; n : Integer; Warning : Boolean);
begin
  if n <= 0 then FPrintF (GetFile (StdErr), NewLine);
  StartRuntimeMessage;
  if Warning then FPrintF (GetFile (StdErr), 'warning: ');
  if Message = nil then Message := '(no message)';
  FPrintF (GetFile (StdErr), '%s (#%d)' + NewLine, Message, n)
end;

end.
