{ Runtime error and signal handling routines

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

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

  This file is part of GNU Pascal.

  GNU Pascal 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.

  GNU Pascal 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 GNU Pascal; see the file COPYING. If not, write to the
  Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  02111-1307, USA.

  As a special exception, if you link this file with files compiled
  with a GNU compiler to produce an executable, this does not cause
  the resulting executable to be covered by the GNU General Public
  License. This exception does not however invalidate any other
  reasons why the executable file might be covered by the GNU
  General Public License. }

{$gnu-pascal,I-}

unit Error; asmname 'GPC';

interface

uses RTSC, String;

const
  EAssert = 381;
  EOpen = 405;
  EOpenRead = 442;
  EOpenWrite = 443;
  EOpenUpdate = 444;
  EReading = 464;
  EWriting = 466;
  ERead = 413;
  EWrite = 414;
  EWriteReadOnly = 422;
  EMMap = 408;
  ECannotFork = 600;
  ECannotSpawn = 601;
  EProgramNotFound = 602;
  EProgramNotExecutable = 603;
  EPipe = 604;
  EPrinterRead = 610;
  EIOCtl = 630;
  EConvertError = 875;
  ELibraryFunction = 952;
  EExitReturned = 953;

  RuntimeErrorExitValue = 42;

  DummyReturnAddress = Pointer ($deadbeef);

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

  { Contains the address of the code where a runtime occurred, nil
    if no runtime error occurred. }
  ErrorAddr: Pointer = nil; asmname '_p_ErrorAddr';

  { Error message }
  ErrorMessageString: TString = ''; asmname '_p_ErrorMessageString';

  { String parameter to some error messages, *not* the text of the
    error message (the latter can be obtained with
    GetErrorMessage). }
  InOutResString: PString = nil; asmname '_p_InOutResString';

  { Optional libc error string to some error messages. }
  InOutResCErrorString: PString = nil; asmname '_p_InOutResCErrorString';

  RTSErrorFD: Integer = -1;    asmname '_p_ErrorFD';
  RTSErrorFileName: PString = nil;   asmname '_p_ErrorFileName';

{@internal}
  { BP compatible InOutRes variable }
  GPC_InOutRes: Integer = 0; asmname '_p_InOutRes';

  RTSWarnFlag: Boolean = False; asmname '_p_RTSWarnFlag';
  AbortOnError: Boolean = False; asmname '_p_AbortOnError';

  CurrentReturnAddr: Pointer = nil;
  CurrentReturnAddrCounter: Integer = 0;

procedure HeapWarning                     (s: CString);                            asmname '_p_HeapWarning';  { For GNU malloc }
procedure GPC_RunError                    (n: Integer);                            attribute (noreturn); asmname '_p_runerror';
procedure StartTempIOError;                                                        asmname '_p_StartTempIOError';
function  EndTempIOError: Integer;                                                 asmname '_p_EndTempIOError';
procedure Finalize;                                                                asmname '_p_finalize';
function  GPC_IOResult: Integer;                                                   asmname '_p_ioresult';
procedure GPC_Halt (aExitCode: Integer);                                           attribute (noreturn); asmname '_p_halt';
{@endinternal}

function  GetErrorMessage                 (n: Integer): CString;                   asmname '_p_errmsg';
procedure RuntimeError                    (n: Integer);                            attribute (noreturn); asmname '_p_error';
procedure RuntimeErrorErrNo               (n: Integer);                            attribute (noreturn); asmname '_p_error_errno';
procedure RuntimeErrorInteger             (n: Integer; i: MedInt);                 attribute (noreturn); asmname '_p_error_integer';
procedure RuntimeErrorCString             (n: Integer; s: CString);                attribute (noreturn); asmname '_p_error_string';
procedure InternalError                   (n: Integer);                            attribute (noreturn); asmname '_p_internal_error';
procedure InternalErrorInteger            (n: Integer; i: MedInt);                 attribute (noreturn); asmname '_p_internal_error_integer';
procedure InternalErrorCString            (n: Integer; s: CString);                attribute (noreturn); asmname '_p_internal_error_string';
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 DebugStatement                  (const FileName: String; Line: Integer); asmname '_p_debug_statement';

{ @@ iocritical } procedure IOError                         (n: Integer; ErrNoFlag: Boolean);                           asmname '_p_io_error';
{ @@ iocritical } procedure IOErrorInteger                  (n: Integer; i: MedInt; ErrNoFlag: Boolean);                asmname '_p_io_error_integer';
{ @@ iocritical } procedure IOErrorCString                  (n: Integer; s: CString; ErrNoFlag: Boolean);               asmname '_p_io_error_cstring';
{ @@ iocritical } procedure IOErrorFile                     (n: Integer; protected var f: AnyFile; ErrNoFlag: Boolean); asmname '_p_io_error_file';

function  GetIOErrorMessage: TString;                                              asmname '_p_get_io_error_message';
procedure CheckInOutRes;                                                           asmname '_p_check_inoutres';

{ Registers a procedure to be called to restore the terminal for
  another process that accesses the terminal, or back for the
  program itself. Used e.g. by the CRT unit. The procedures must
  allow for being called multiple times in any order, even at the
  end of the program (see the comment for RestoreTerminal). }
procedure RegisterRestoreTerminal (ForAnotherProcess: Boolean; procedure Proc); asmname '_p_RegisterRestoreTerminal';

{ Unregisters a procedure registered with RegisterRestoreTerminal.
  Returns False if the procedure had not been registered, and True
  if it had been registered and was unregistered successfully. }
function  UnregisterRestoreTerminal (ForAnotherProcess: Boolean; procedure Proc): Boolean; asmname '_p_UnregisterRestoreTerminal';

{ Calls the procedures registered by RegisterRestoreTerminal. When
  restoring the terminal for another process, the procedures are
  called in the opposite order of registration. When restoring back
  for the program, they are called in the order of registration.

  `RestoreTerminal (True)' will also be called at the end of the
  program, before outputting any runtime error message. It can also
  be used if you want to write an error message and exit the program
  (especially when using e.g. the CRT unit). For this purpose, to
  avoid side effects, call RestoreTerminal immediately before
  writing the error message (to StdErr, not to Output!), and then
  exit the program (e.g. with Halt). }
procedure RestoreTerminal (ForAnotherProcess: Boolean); asmname '_p_RestoreTerminal';

procedure AtExit (procedure Proc); asmname '_p_atexit';

function  ReturnAddr2Hex (p: Pointer): TString; asmname '_p_ReturnAddr2Hex';

{ This function is used to write error messages etc. It does not use
  the Pascal I/O system here because it is usually called at the
  very end of a program after the Pascal I/O system has been shut
  down. }
function  WriteErrorMessage (const s: String; StdErrFlag: Boolean): Boolean; asmname '_p_WriteErrorMessage';

procedure SetReturnAddress (Address: Pointer); asmname '_p_SetReturnAddress';
procedure RestoreReturnAddress; asmname '_p_RestoreReturnAddress';
function  SetTempDummyReturnAddress: Pointer; asmname '_p_SetTempDummyReturnAddress';
procedure RestoreTempReturnAddress (Address: Pointer); asmname '_p_RestoreTempReturnAddress';

{ Returns a description for a signal }
function  StrSignal (Signal: Integer): TString; asmname '_p_strsignal';

{ Installs some signal handlers that cause runtime errors on certain
  signals. This procedure runs only once, and returns immediately
  when called again (so you can't use it to set the signals again if
  you changed them meanwhile). @@Does not work on all systems (since
  the handler might have too little stack space). }
procedure InstallDefaultSignalHandlers; asmname '_p_InstallDefaultSignalHandlers';

var
  { Signal actions }
  SignalDefault: TSignalHandler; asmname '_p_SIG_DFL'; external;
  SignalIgnore : TSignalHandler; asmname '_p_SIG_IGN'; external;
  SignalError  : TSignalHandler; asmname '_p_SIG_ERR'; external;

  { Signals. The constants are set to the signal numbers, and
    are 0 for signals not defined. }
  { POSIX signals }
  SigHUp   : Integer; asmname '_p_SIGHUP'; external;
  SigInt   : Integer; asmname '_p_SIGINT'; external;
  SigQuit  : Integer; asmname '_p_SIGQUIT'; external;
  SigIll   : Integer; asmname '_p_SIGILL'; external;
  SigAbrt  : Integer; asmname '_p_SIGABRT'; external;
  SigFPE   : Integer; asmname '_p_SIGFPE'; external;
  SigKill  : Integer; asmname '_p_SIGKILL'; external;
  SigSegV  : Integer; asmname '_p_SIGSEGV'; external;
  SigPipe  : Integer; asmname '_p_SIGPIPE'; external;
  SigAlrm  : Integer; asmname '_p_SIGALRM'; external;
  SigTerm  : Integer; asmname '_p_SIGTERM'; external;
  SigUsr1  : Integer; asmname '_p_SIGUSR1'; external;
  SigUsr2  : Integer; asmname '_p_SIGUSR2'; external;
  SigChld  : Integer; asmname '_p_SIGCHLD'; external;
  SigCont  : Integer; asmname '_p_SIGCONT'; external;
  SigStop  : Integer; asmname '_p_SIGSTOP'; external;
  SigTStp  : Integer; asmname '_p_SIGTSTP'; external;
  SigTTIn  : Integer; asmname '_p_SIGTTIN'; external;
  SigTTOu  : Integer; asmname '_p_SIGTTOU'; external;

  { Non-POSIX signals }
  SigTrap  : Integer; asmname '_p_SIGTRAP'; external;
  SigIOT   : Integer; asmname '_p_SIGIOT'; external;
  SigEMT   : Integer; asmname '_p_SIGEMT'; external;
  SigBus   : Integer; asmname '_p_SIGBUS'; external;
  SigSys   : Integer; asmname '_p_SIGSYS'; external;
  SigStkFlt: Integer; asmname '_p_SIGSTKFLT'; external;
  SigUrg   : Integer; asmname '_p_SIGURG'; external;
  SigIO    : Integer; asmname '_p_SIGIO'; external;
  SigPoll  : Integer; asmname '_p_SIGPOLL'; external;
  SigXCPU  : Integer; asmname '_p_SIGXCPU'; external;
  SigXFSz  : Integer; asmname '_p_SIGXFSZ'; external;
  SigVTAlrm: Integer; asmname '_p_SIGVTALRM'; external;
  SigProf  : Integer; asmname '_p_SIGPROF'; external;
  SigPwr   : Integer; asmname '_p_SIGPWR'; external;
  SigInfo  : Integer; asmname '_p_SIGINFO'; external;
  SigLost  : Integer; asmname '_p_SIGLOST'; external;
  SigWinCh : Integer; asmname '_p_SIGWINCH'; external;

  { Signal subcodes (only used on some systems, -1 if not used) }
  FPEIntegerOverflow      : Integer; asmname '_p_FPE_INTOVF_TRAP'; external;
  FPEIntegerDivisionByZero: Integer; asmname '_p_FPE_INTDIV_TRAP'; external;
  FPESubscriptRange       : Integer; asmname '_p_FPE_SUBRNG_TRAP'; external;
  FPERealOverflow         : Integer; asmname '_p_FPE_FLTOVF_TRAP'; external;
  FPERealDivisionByZero   : Integer; asmname '_p_FPE_FLTDIV_TRAP'; external;
  FPERealUnderflow        : Integer; asmname '_p_FPE_FLTUND_TRAP'; external;
  FPEDecimalOverflow      : Integer; asmname '_p_FPE_DECOVF_TRAP'; external;

{ Routines for the `is' and `as' operators. }
function  ObjectTypeIs (Left, Right: PObjectType): Boolean; attribute (const); asmname '_p_ObjectTypeIs';
procedure ObjectTypeAsError; asmname '_p_ObjectTypeAsError';

implementation

{$ifndef HAVE_NO_RTS_CONFIG_H}
{$include "rts-config.inc"}
{$endif}

const
  InternalErrorString = 'internal error: ';

  ErrorMessages: array [1 .. 216] of record
    Number: Integer;
    Message: CString
  end =
  (
    { Note: use just `%' for the optional argument to the messages.
      The errors are not written using one of the `printf' functions
      anymore, but a more Pascalish formatting that gets knowledge
      about the type of the argument from its caller. Any character
      following the `%' becomes part of the actual error message! }

    { Leave the `Byte' range free for program specific errors. }

    { Signal handlers }
    (257, 'hangup signal received'),
    (258, 'interrupt signal received'),
    (259, 'quit signal received'),
    (260, 'invalid instruction signal received'),
    (261, 'trap signal received'),
    (262, 'I/O trap signal received'),
    (263, 'emulator trap signal received'),
    (264, 'floating point exception signal received'),
    (266, 'bus error signal received'),
    (267, 'segmentation fault signal received'),
    (268, 'bad system call signal received'),
    (269, 'broken pipe signal received'),
    (270, 'alarm signal received'),
    (271, 'termination signal received'),

    { 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'),
    (309, 'range error in set constructor'),
    (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 to `Sqr'' out of range'),
    (337, 'argument to `Chr'' out of range'),
    (338, 'argument to `Succ'' out of range'),
    (339, 'argument to `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'),
    (387, 'left operand of `as'' is not of required type'),

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

    { I/O errors: File and general I/O errors }
    { For errors raised with IOERROR_FILE, the "%" 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, 'file buffer size of % must be > 0'),
    (401, 'cannot open directory `%'''),
    (402, '`Bind'' applied to non-bindable %'),
    (403, '`Binding'' applied to non-bindable %'),
    (404, '`Unbind'' applied to non-bindable %'),
    (405, 'cannot open `%'''),
    (406, 'attempt to read past end of random access %'),
    (407, '% has not been opened'),
    (408, 'cannot map % into memory'),
    (409, 'cannot unmap memory'),
    (410, 'attempt to access elements before beginning of random access %'),
    (411, 'attempt to modify read only %'),
  { (412, 'random access % back stepping failed'), }
    (413, 'read error'),
    (414, 'write error'),
    (415, 'cannot read all the data from % in `BlockRead'''),
    (416, '`Extend'' could not seek to end of %'),
    (417, '`FilePos'' could not get file position of %'),
    (418, 'error while closing %'),
    (419, 'cannot prompt user for external name bindings for %'),
    (420, 'cannot query user for external name bindings for %'),
    (421, 'EOT character given for query of name for %'),
    (422, 'cannot write to read only %'),
    (424, 'invalid string length in `Bind'' of %'),
    (425, 'truncation failed for %'),
    (426, '`SeekRead'' to write only %'),
    (427, '`SeekRead'' seek failed on %'),
    (428, '`SeekRead'' failed to reset position of %'),
    (429, '`SeekWrite'' seek failed on %'),
    (430, '`SeekUpdate'' to read-only or write-only %'),
    (431, '`SeekUpdate'' seek failed on %'),
    (432, '`SeekUpdate'' failed to reset position of %'),
    (433, '`Update'' failed to reset the position of %'),
    (436, '`Reset'', `SeekUpdate'' or `SeekRead'' to nonexistent %'),
    (438, '`Truncate'' or `DefineSize'' applied to read only %'),
    (439, '`Update'' with an undefined buffer in %'),
    (440, 'reference to buffer variable of % with undefined value'),
    (441, 'file already bound to `%'''),
    (442, 'cannot open % for reading'),
    (443, 'cannot open % for writing'),
    (444, 'cannot open % for updating'),
    (445, 'cannot extend %'),
    (446, 'cannot get the size of %'),
    (450, '% is not open for writing'),
    (452, '% is not open for reading'),
    (454, 'attempt to read past end of %'),
    (455, '`EOF'' tested for unopened %'),
    (456, '`EOLn'' tested for unopened %'),
    (457, '`EOLn'' tested for % when `EOF'' is True'),
    (458, '`EOLn'' applied to a non-text %'),
  { (460, '% not found'),
    (461, 'cannot access %'),
    (462, 'attempt to open % as external'),
    (463, '% is write protected'), }
    (464, 'error when reading from %'),
    (465, 'cannot read all the data from %'),
    (466, 'error when writing to %'),
    (467, 'cannot write all the data to %'),
    (468, 'cannot erase %'),
    (469, '`Erase'': external file `%'' has no external name'),
    (473, '`Erase'': cannot erase directory `%'''),
    (474, 'error when trying to erase %'),
    (475, 'cannot rename %'),
    (476, '`Rename/FileMove'': external file `%'' has no external name'),
    (477, 'cannot rename opened %'),
    (481, 'error when trying to rename %'),
    (482, '`Rename'': cannot overwrite file `%'''),
    (483, 'cannot change to directory `%'''),
    (484, 'cannot make directory `%'''),
    (485, 'cannot remove directory `%'''),
    (486, '`SetFTime'': file `%'' has no external name'),
    (487, 'cannot set time for %'),
    (488, '`Execute'': cannot execute program'),
    (491, '`ChMod'': file `%'' has no external name'),
    (494, 'error when trying to change mode of %'),
    (495, 'cannot open directory `%'''),
    (497, 'no temporary file name found'),
    (498, '`ChOwn'': file `%'' has no external name'),
    (499, 'error when trying to change owner of %'),

    { 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 }
    (566, 'invalid Boolean value read'),
    (567, 'invalid enumaration value read'),

    { I/O errors: Write errors }
    (580, 'fixed field width cannot be negative'),
    (581, 'fixed real fraction field width cannot be negative'),
    (582, 'string capacity exceeded in `WriteStr'''),

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

    { I/O errors: device specific errors }
    (600, 'cannot fork program `%'''),
    (601, 'cannot spawn `%'''),
    (602, 'program `%'' not found'),
    (603, 'program `%'' not executable'),
    (604, 'cannot create pipe to program `%'''),

    (610, 'printer can only be opened for writing'),
    (620, 'unknown serial port #%'),
    (621, 'serial port #% cannot be opened'),
    (630, 'error % in ioctl'),

    { Mathematical errors }
    (700, 'error in exponentiation'),
    (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 to `Ln'' is <= 0'),
    (708, 'argument to `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'),
    (717, 'decimal overflow'),
    (718, 'subscript error'),

    { 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 a position 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, 'address % is not valid for `Release'''),
    (853, 'out of heap when allocating % bytes'),
    (854, 'out of heap when reallocating % bytes'),
  { (855, 'attempt to use disposed pointer'),
    (856, 'attempt to use disposed object'), }
    (857, 'attempt to map unmappable memory'),

    { Errors for units }
    (870, 'BP compatible 6 byte `Real'' type does not support NaNs'),
    (871, 'BP compatible 6 byte `Real'' type does not support infinity'),
    (872, 'underflow while converting to BP compatible 6 byte `Real'' type'),
    (873, 'overflow while converting to BP compatible 6 byte `Real'' type'),
    (874, 'cannot convert denormalized number to BP compatible 6 byte `Real'' type'),
    (875, 'cannot convert string to an integer'),

    (880, 'CRT was not initialized'),
    (881, 'CRT: error opening terminal'),
    (882, 'attempt to delete invalid CRT panel'),
    (883, 'attempt to delete last CRT panel'),
    (884, 'attempt to activate invalid CRT panel'),

    { Internal errors }
    (900, 'internal error in `%'''),
    (901, 'compiler calls `ReadLn'' incorrectly'),
    (902, 'compiler calls `WriteLn'' incorrectly'),
    (903, 'unknown code in `Read'' or `ReadStr'''),
    (904, 'unknown code in `Write'' or `WriteStr'''),
    (906, 'unknown string code in `WriteStr'''),
    (907, 'string capacity cannot be negative'),
    (908, 'incorrect reading of a string'),
    (909, 'endianness incorrectly defined');
    (910, 'read buffer underflow');
    (911, 'invalid file open mode');
    (912, 'file has no internal name'),
    (913, '`InitFDR'' has not been called for file'),

    { Internal errors for units }
    (950, 'CRT: cannot initialize curses'),
    (951, 'cannot create CRT window'),
    (952, 'library function `%'' missing'),
    (953, '`_exit returned')
  );

  SignalTable: array [1 .. 21] of record
    Signal, Code: ^Integer;  { @@ }
    ErrorNumber: Integer  { negative if warning }
  end =
  (
    (@SigHUp,  nil, 257),
    (@SigInt,  nil, 258),
    (@SigQuit, nil, 259),
    (@SigIll,  nil, 260),
    (@SigFPE,  @FPEIntegerOverflow,        713),
    (@SigFPE,  @FPEIntegerDivisionByZero,  712),
    (@SigFPE,  @FPESubscriptRange,         718),
    (@SigFPE,  @FPERealOverflow,           715),
    (@SigFPE,  @FPERealDivisionByZero,     711),
    (@SigFPE,  @FPERealUnderflow,         -716),
    (@SigFPE,  @FPEDecimalOverflow,        717),
    (@SigFPE,  nil, 264),
    (@SigSegV, nil, 267),
    (@SigPipe, nil, 269),
    (@SigAlrm, nil, 270),
    (@SigTerm, nil, 271),
    (@SigTrap, nil, 261),
    (@SigIOT,  nil, 262),
    (@SigEMT,  nil, 263),
    (@SigBus,  nil, 266),
    (@SigSys,  nil, 268)
  );

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

function ObjectTypeIs (Left, Right: PObjectType): Boolean;
begin
  while (Left <> nil) and (Left <> Right) do Left := Left^.Parent;
  ObjectTypeIs := Left <> nil
end;

procedure ObjectTypeAsError;
begin
  SetReturnAddress (ReturnAddress (0));
  RuntimeError (387);  { left operand of `as'' is not of required type }
  RestoreReturnAddress
end;

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;

{ Very simple replacement for `sprintf'. This function is probably
  not very useful for general purposes, and is therefore not
  declared in the interface. It's only here to format the error
  messages above. }
function FormatStr (Format: CString; const Argument: String) = s: TString;
var i: Integer;
begin
  s := CString2String (Format);
  i := Pos ('%', s);
  if i = 0 then
    s := 'internal error: error handling was called incorrectly: ' + s + ' (' + Argument + ')'
  else
    begin
      Delete (s, i, 1);
      Insert (Argument, s, i)
    end
end;

function StartRuntimeWarning = Result: Boolean;
begin
  Result := RTSWarnFlag;
  if Result then Write (StdErr, ParamStr (0), ': warning: ')
end;

procedure RuntimeWarning (Message: CString);
begin
  if StartRuntimeWarning then
    WriteLn (StdErr, { @@ stack problem } {$local X+} Message) {$endlocal}
end;

procedure RuntimeWarningInteger (Message: CString; i: MedInt);
begin
  if StartRuntimeWarning then
    WriteLn (StdErr, FormatStr (Message, Integer2String (i)))
end;

procedure RuntimeWarningCString (Message: CString; s: CString);
begin
  if StartRuntimeWarning then
    WriteLn (StdErr, FormatStr (Message, CString2String (s)))
end;

procedure DebugStatement (const FileName: String; Line: Integer);
begin
  WriteLn (StdErr, FileName, ':', Line, ': DebugStatement')
end;

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

var
  RestoreTerminalProcs: array [Boolean] of PProcList = (nil, nil);
  AtExitProcs: PProcList = nil;

procedure InsertProcList (var List: PProcList; procedure Proc);
var
  p: PProcList;
  RA: Pointer;
begin
  RA := SetTempDummyReturnAddress;
  New (p);
  RestoreTempReturnAddress (RA);
  p^.Proc := @Proc;
  p^.Prev := nil;
  p^.Next := List;
  if p^.Next <> nil then p^.Next^.Prev := p;
  List := p
end;

procedure RegisterRestoreTerminal (ForAnotherProcess: Boolean; procedure Proc);
begin
  InsertProcList (RestoreTerminalProcs[ForAnotherProcess], Proc)
end;

function UnregisterRestoreTerminal (ForAnotherProcess: Boolean; procedure Proc): Boolean;
var p: PProcList;
begin
  p := RestoreTerminalProcs[ForAnotherProcess];
  while (p <> nil) and (p^.Proc <> @Proc) do p := p^.Next;
  if p = nil then
    UnregisterRestoreTerminal := False
  else
    begin
      if p^.Next <> nil then p^.Next^.Prev := p^.Prev;
      if p^.Prev = nil
        then RestoreTerminalProcs[ForAnotherProcess] := p^.Next
        else p^.Prev^.Next := p^.Next;
      Dispose (p);
      UnregisterRestoreTerminal := True
    end
end;

procedure RestoreTerminal (ForAnotherProcess: Boolean);
var p: PProcList;
begin
  SetReturnAddress (ReturnAddress (0));
  p := RestoreTerminalProcs[ForAnotherProcess];
  if ForAnotherProcess then
    while p <> nil do
      begin
        p^.Proc^;
        p := p^.Next
      end
  else if p <> nil then
    begin
      while p^.Next <> nil do p := p^.Next;
      while p <> nil do
        begin
          p^.Proc^;
          p := p^.Prev
        end
    end;
  RestoreReturnAddress
end;

procedure AtExit (procedure Proc);
begin
  InsertProcList (AtExitProcs, Proc)
end;

function ReturnAddr2Hex (p: Pointer) = s: TString;
const HexDigits: array [0 .. $f] of Char = '0123456789abcdef';
var i, j: PtrCard;
begin
  s := '';
  { Subtract 1 to get a pointer to the last byte of the corresponding call
    instruction. This might not be fool-proof, but perhaps the best we can do. }
  i := PtrCard (p) - 1;
  j := 1;
  while j <= i div $10 do
    j := $10 * j;
  while j > 0 do
    begin
      s := s + HexDigits[i div j];
      i := i mod j;
      j := j div $10
    end
end;

function WriteErrorMessage (const s: String; StdErrFlag: Boolean): Boolean;
var Handle: Integer;
begin
  if StdErrFlag then
    begin
      Handle := FileHandle (StdErr);
      if Handle < 0 then Handle := 2
    end
  else
    begin
      if (RTSErrorFD < 0) and (RTSErrorFileName <> nil) then
        begin
          RTSErrorFD := OpenHandle (RTSErrorFileName^, MODE_WRITE or MODE_CREATE or MODE_TRUNCATE);
          Dispose (RTSErrorFileName);
          RTSErrorFileName := nil
        end;
      Handle := RTSErrorFD
    end;
  WriteErrorMessage := (Handle >= 0) and (WriteHandle (Handle, @s[1], Length (s)) >= 0)
end;

procedure WriteStackDump;
var
  i: Integer { @@false warning } = 0;
  a: Pointer { @@false warning } = nil;
  Dummy: Boolean;
begin
  Dummy := WriteErrorMessage (ParamStr (0) + ': ' + ErrorMessageString + NewLine, True);
  i := 0;
  if WriteErrorMessage (ErrorMessageString + NewLine, False) and
     WriteErrorMessage (ReturnAddr2Hex (ErrorAddr) + NewLine, False) and
     WriteErrorMessage ('Routines called:' + NewLine, False) then
    repeat
      case i of
         0: a := ReturnAddress  (0);
        {$ifdef HAVE_RETURN_ADDRESS_NON_ZERO}
         1: a := ReturnAddress  (1);
         2: a := ReturnAddress  (2);
         3: a := ReturnAddress  (3);
         4: a := ReturnAddress  (4);
         5: a := ReturnAddress  (5);
         6: a := ReturnAddress  (6);
         7: a := ReturnAddress  (7);
         8: a := ReturnAddress  (8);
         9: a := ReturnAddress  (9);
        10: a := ReturnAddress (10);
        11: a := ReturnAddress (11);
        12: a := ReturnAddress (12);
        13: a := ReturnAddress (13);
        14: a := ReturnAddress (14);
        15: a := ReturnAddress (15);
        {$endif}
        else a := nil
      end;
      Inc (i)
    until (i = 16) or (a = nil) or not WriteErrorMessage (ReturnAddr2Hex (a) + NewLine, False)
end;

procedure Finalize1;
begin
  FlushAllFiles;
  RestoreTerminal (True);
  GPC_Done_Files;
  if ErrorMessageString <> '' then WriteStackDump
end;

procedure Finalize;
begin
  ErrorMessageString := '';
  ExitCode := 0;
  ErrorAddr := nil;
  RunFinalizers (AtExitProcs);
  Finalize1
end;

procedure GPC_Halt (aExitCode: Integer);
begin
  ErrorMessageString := '';
  ExitCode := aExitCode;
  ErrorAddr := nil;
  RunFinalizers (AtExitProcs);
  Finalize1;
  ExitProgram (aExitCode, False)
end;

procedure SetReturnAddress (Address: Pointer);
begin
  if CurrentReturnAddrCounter = 0 then CurrentReturnAddr := Address;
  Inc (CurrentReturnAddrCounter)
end;

procedure RestoreReturnAddress;
begin
  Dec (CurrentReturnAddrCounter);
  if CurrentReturnAddrCounter = 0 then CurrentReturnAddr := nil
end;

function SetTempDummyReturnAddress: Pointer;
begin
  SetTempDummyReturnAddress := CurrentReturnAddr;
  CurrentReturnAddr := DummyReturnAddress;
  Inc (CurrentReturnAddrCounter)
end;

procedure RestoreTempReturnAddress (Address: Pointer);
begin
  Dec (CurrentReturnAddrCounter);
  CurrentReturnAddr := Address
end;

procedure FinishErrorMessage (n: Integer);
var s: TString;
begin
  ExitCode := n;
  ErrorAddr := CurrentReturnAddr;
  CurrentReturnAddr := nil;
  CurrentReturnAddrCounter := 0;
  s := ReturnAddr2Hex (ErrorAddr);
  { @@ stack problem } var foo:CString;foo:=ErrorMessageString;{$local X+}WriteStr (ErrorMessageString, foo, ' (error #', n, ' at ', s, ')'){$endlocal}
end;

procedure EndRuntimeError (n: Integer); attribute (noreturn); asmname '_p_end_runtime_error';
procedure EndRuntimeError (n: Integer);
var Dummy: Integer;
begin
  FinishErrorMessage (n);
  RunFinalizers (AtExitProcs);
  Finalize1;
  if (RTSErrorFD >= 0) then Dummy := CloseHandle (RTSErrorFD);  { just to be sure }
  ExitProgram (RuntimeErrorExitValue, AbortOnError)
end;

procedure RuntimeError (n: Integer);
begin
  SetReturnAddress (ReturnAddress (0));
  ErrorMessageString := CString2String (GetErrorMessage (n));
  EndRuntimeError (n)
end;

function StrError = Res: TString;
var
  ErrNo: Integer;
  s: CString;
begin
  s := CStringStrError (ErrNo);
  if s <> nil then
    Res := CString2String (s)
  else
    WriteStr (Res, 'error #', ErrNo)
end;

function StrSignal (Signal: Integer) = Res: TString;
var s: CString;
begin
  s := CStringStrSignal (Signal);
  if s <> nil then
    Res := CString2String (s)
  else
    WriteStr (Res, 'signal #', Signal)
end;

procedure RuntimeErrorErrNo (n: Integer);
begin
  SetReturnAddress (ReturnAddress (0));
  ErrorMessageString := CString2String (GetErrorMessage (n)) + ' (' + StrError + ')';
  EndRuntimeError (n)
end;

procedure RuntimeErrorInteger (n: Integer; i: MedInt);
begin
  SetReturnAddress (ReturnAddress (0));
  ErrorMessageString := FormatStr (GetErrorMessage (n), Integer2String (i));
  EndRuntimeError (n)
end;

procedure RuntimeErrorCString (n: Integer; s: CString);
begin
  SetReturnAddress (ReturnAddress (0));
  ErrorMessageString := FormatStr (GetErrorMessage (n), CString2String (s));
  EndRuntimeError (n)
end;

procedure InternalError (n: Integer);
begin
  SetReturnAddress (ReturnAddress (0));
  ErrorMessageString := InternalErrorString + CString2String (GetErrorMessage (n));
  EndRuntimeError (n)
end;

procedure InternalErrorInteger (n: Integer; i: MedInt);
begin
  SetReturnAddress (ReturnAddress (0));
  ErrorMessageString := InternalErrorString + FormatStr (GetErrorMessage (n), Integer2String (i));
  EndRuntimeError (n)
end;

procedure InternalErrorCString (n: Integer; s: CString);
begin
  SetReturnAddress (ReturnAddress (0));
  ErrorMessageString := InternalErrorString + FormatStr (GetErrorMessage (n), CString2String (s));
  EndRuntimeError (n)
end;

procedure GPC_RunError (n: Integer);
begin
  SetReturnAddress (ReturnAddress (0));
  ErrorMessageString := 'runtime error';
  EndRuntimeError (n)
end;

inline function GPC_IOResult: Integer;
begin
  GPC_IOResult := GPC_InOutRes;
  GPC_InOutRes := 0
end;

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

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

procedure SetInOutResStrings (s: PString; ErrNoFlag: Boolean);
var RA: Pointer;
begin
  if InOutResString <> nil then Dispose (InOutResString);
  InOutResString := s;
  if InOutResCErrorString <> nil then Dispose (InOutResCErrorString);
  if ErrNoFlag then
    begin
      RA := SetTempDummyReturnAddress;
      InOutResCErrorString := NewString (StrError);
      RestoreTempReturnAddress (RA)
    end
  else
    InOutResCErrorString := nil
end;

procedure IOError (n: Integer; ErrNoFlag: Boolean);
begin
  GPC_InOutRes := n;
  if not TempIOErrorFlag then
    SetInOutResStrings (nil, ErrNoFlag)
end;

procedure IOErrorInteger (n: Integer; i: MedInt; ErrNoFlag: Boolean);
var RA: Pointer;
begin
  GPC_InOutRes := n;
  if not TempIOErrorFlag then
    begin
      RA := SetTempDummyReturnAddress;
      SetInOutResStrings (NewString (Integer2String (i)), ErrNoFlag);
      RestoreTempReturnAddress (RA)
    end
end;

procedure IOErrorCString (n: Integer; s: CString; ErrNoFlag: Boolean);
var RA: Pointer;
begin
  GPC_InOutRes := n;
  if not TempIOErrorFlag then
    begin
      RA := SetTempDummyReturnAddress;
      SetInOutResStrings (NewString (CString2String (s)), ErrNoFlag);
      RestoreTempReturnAddress (RA)
    end
end;

procedure IOErrorFile (n: Integer; protected var f: AnyFile; ErrNoFlag: Boolean);
begin
  IOErrorCString (n, CString2String (GetErrorMessageFileName (f)), ErrNoFlag)
end;

function GetIOErrorMessage = Res: TString;
begin
  if InOutResString <> nil
    then Res := FormatStr (GetErrorMessage (GPC_IOResult), InOutResString^)
    else Res := CString2String (GetErrorMessage (GPC_IOResult));
  if InOutResCErrorString <> nil then
    Res := Res + ' (' + InOutResCErrorString^ + ')'
end;

procedure CheckInOutRes;
var n: Integer;
begin
  if GPC_InOutRes <> 0 then
    begin
      SetReturnAddress (ReturnAddress (0));
      n := GPC_InOutRes;
      ErrorMessageString := GetIOErrorMessage;
      EndRuntimeError (n)
    end
end;

procedure DefaultSignalHandler (Signal, Code: Integer);
var
  i, n: Integer;
  HandlerReset, Dummy: Boolean;
begin
  HandlerReset := InstallSignalHandler (Signal, SignalDefault, True, False, Null, Null);
  i := Low (SignalTable);
  while (i < High (SignalTable)) and not ((SignalTable[i].Signal^ = Signal) and
         ((SignalTable[i].Code = nil) or (SignalTable[i].Code^ = Code))) do Inc (i);
  n := SignalTable[i].ErrorNumber;
  if n < 0 then
    begin
      RuntimeWarning (GetErrorMessage (-n));  { @@ stack problem when using strings here }
      Dummy := InstallSignalHandler (Signal, TSignalHandler (@DefaultSignalHandler), True, True, Null, Null)
    end
  else
    begin
      WriteStr (ErrorMessageString, { @@ stack problem } {$local X+} GetErrorMessage (n), ' (#', n, ')'); {$endlocal}
      { Return address not available or meaningful in a signal handler }
      SetReturnAddress (DummyReturnAddress);
      FinishErrorMessage (n);
      { @@ stack problem } var foo:CString;foo:=ErrorMessageString;{$local X+}WriteLn (StdErr, ParamStr (0), ': ', foo){$endlocal};
      ErrorMessageString := '';
      if HandlerReset then
        Dummy := Kill (ProcessID, Signal)
    end
end;

procedure InstallDefaultSignalHandlers;
var
  Done: static Boolean = False;
  Dummy: Boolean;
begin
  { Run only once. }
  if Done then Exit;
  Done := True;
  {$if False}  { @@ doesn't work because of limited sets -- signal ids can be > 255, e.g. on DJGPP }
  Signal: Integer;
  for Signal in [SigHUp, SigInt, { SigQuit, } SigIll, SigFPE, SigSegV, SigPipe,
                 SigAlrm, SigTerm, SigTrap, SigIOT, SigEMT, SigBus, SigSys] do
    Dummy := InstallSignalHandler (Signal, TSignalHandler (@DefaultSignalHandler), True, True, Null, Null)
  {$else}
  {$define I(S) Dummy := InstallSignalHandler (S, TSignalHandler (@DefaultSignalHandler), True, True, Null, Null)}
  I (SigHUp); I (SigInt); { I(SigQuit); } I (SigIll); I (SigFPE); I (SigSegV); I (SigPipe);
  I (SigAlrm); I (SigTerm); I (SigTrap); I (SigIOT); I (SigEMT); I (SigBus); I (SigSys);
  {$endif}
end;

end.
