{ Initialization

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

  Authors: Frank Heckenbach <frank@pascal.gnu.de>

  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 Init; asmname 'GPC';

interface

{@internal}
{ Use all RTS units, so their initializers are run from here. }

uses RTSC, String, Error, String2, Time, Random, FileName, Files,
     GetOpt, NumToDec, Sets, Heap, Math, Endian, Move;

procedure InitDummy; asmname '_p_InitDummy';
procedure DoInitProc; asmname '_p_doinitproc';
procedure GPC_Initialize (ArgumentCount: Integer; Arguments, StartEnvironment: PCStrings); asmname '_p_initialize';
{@endinternal}

var
  InitProc: ^procedure = @InitDummy; asmname '_p_initproc';

implementation

{ Declare a variable whose presence can be checked at link time
  to ensure that the correct RTS version is linked. }
{$ifndef RTS_RELEASE_STRING}
{$error RTS_RELEASE_STRING not set! Please compile this file properly from
the Makefile, or define that symbol manually if you know what you are doing.}
{$endif}
var
  RTSReleaseCheck: Integer = $47525453; asmname '__GPC_RTS_VERSION_' { @@@@ + RTS_RELEASE_STRING + '__' };

procedure InitDummy;
begin
end;

{ Handle options for the Run Time System from the command line.
  Since the normal use of the command line is passing arguments to
  the user program, passing arguments to the runtime system is made
  somewhat complicated: The first argument has to be `--gpc-rts'.
  Other flags that the RTS recognizes (if the first argument is
  `--gpc-rts') are output with the `-h' option (see below). `--'
  indicates the end of RTS arguments. }
procedure InitArguments;
const
  Prefix = 'gpc-rts';
  PrefixOption = '--' + Prefix;
var
  ArgsDone: static Boolean = False;
  SkipArgs, NoSkip, OK: Boolean;
  i, CParamCountSave: Integer;
  CParameter1Save: CString;
  InputFile: ^Text = nil;  { `-i' option strings written here, and given
                             as standard input to user program }

  procedure Help (Status: Integer);
  begin
    Write ('Special command line options to the GPC Run Time System:
[' + PrefixOption + '=OPTION ' + PrefixOption + '=OPTION ...] [' + PrefixOption + ' OPTION OPTION ... [--]]

OPTION may be:
-h, --help                Display this help and exit
-v, --version             Output RTS version information and exit
-a, --abort-on-error      Abort with SIGABRT on runtime error
-e, --eoln-hack           Toggle EOLn hack right after Reset for terminals
-f, --direct-files        Toggle forcing direct access files
-i LINE, --input LINE     Implicitly add LINE to the beginning of Input
-n INTERNAL_NAME:EXTERNAL_NAME, --file-name[=]INTERNAL_NAME:EXTERNAL_NAME
                          Set an external file name
-S, --signal-handlers     Install signal handlers that cause runtime
                          errors on certain signals. @@Does not work
                          on all systems (since the handler might
                          have too little stack space).
-s, --show-rts-arguments  Let the program see RTS command line arguments
-w, --warn                Give runtime warning messages
-E FILENAME, --error-file[=]FILENAME
                          Write runtime error messages and stack dump to
                          FILENAME
-F FD, --error-fd[=]FD    Write runtime error messages and stack dump to
                          fd #FD
--                        Following arguments are not meant for the RTS
');
    Halt (Status)
  end;

  function DoOption: Boolean;
  const
    LongOptions: array [1 .. 13] of OptionType =
      ((Prefix,               NoArgument,       nil, '='),
       ('help',               NoArgument,       nil, 'h'),
       ('version',            NoArgument,       nil, 'v'),
       ('abort-on-error',     NoArgument,       nil, 'a'),
       ('eoln-hack',          NoArgument,       nil, 'e'),
       ('direct-files',       NoArgument,       nil, 'f'),
       ('input',              RequiredArgument, nil, 'i'),
       ('file-name',          RequiredArgument, nil, 'n'),
       ('signal-handlers',    NoArgument,       nil, 'S'),
       ('show-rts-arguments', NoArgument,       nil, 's'),
       ('warn',               NoArgument,       nil, 'w'),
       ('error-file',         RequiredArgument, nil, 'E'),
       ('error-fd',           RequiredArgument, nil, 'F'));
  var
    c: Char;
    ap: PFileAssociation;
    p, fd: Integer;
    SaveGetOptErrorFlag: Boolean;
  begin
    DoOption := False;
    SaveGetOptErrorFlag := GetOptErrorFlag;
    GetOptErrorFlag := False;
    c := GetOptLong ('+-', LongOptions, Null, False);
    GetOptErrorFlag := SaveGetOptErrorFlag;
    if c = EndOfOptions then Exit;
    SkipArgs := True;
    case c of
      '=': ;  { Ignore multiple prefix arguments }
      'h': Help (0);
      'v': begin
             WriteLn ('GNU Pascal Run Time System version ' + RTS_RELEASE_STRING + '
Copyright (C) 1987-2002 Free Software Foundation, Inc.
The GNU Pascal RTS comes with NO WARRANTY, to the extent permitted
by law. You may redistribute copies of the GNU Pascal RTS under the
terms of the GNU General Public License. For more information about
these matters, see the file named COPYING.

Report bugs to <gpc@gnu.de>.
');
             Halt
           end;
      'a': AbortOnError := True;
      'e': EOLnResetHack := not EOLnResetHack;
      'f': ForceDirectFiles := not ForceDirectFiles;
      'i': begin
             if InputFile = nil then
               begin
                 New (InputFile);
                 Rewrite (InputFile^)
               end;
             WriteLn (InputFile^, OptionArgument)
           end;
      'n': begin
             p := Pos (':', OptionArgument);
             if p = 0 then
               begin
                 WriteLn (StdErr, ParamStr (0), ': missing external file name for `', OptionArgument, '''' + NewLine);
                 Help (1)
               end
             else
               begin
                 New (ap);
                 ap^.Next := FileAssociation;
                 ap^.IntName := NewCString (Copy (OptionArgument, 1, p - 1));
                 ap^.ExtName := NewCString (Copy (OptionArgument, p + 1));
                 FileAssociation := ap
               end
           end;
      'S': InstallDefaultSignalHandlers;
      's': NoSkip := True;
      'w': RTSWarnFlag := True;
      'E': RTSErrorFileName := NewString (OptionArgument);
      'F': begin
             {$local I+} ReadStr (OptionArgument, fd); {$endlocal}
             RTSErrorFD := fd
           end;
      else
        Dec (FirstNonOption);
        Exit
    end;
    DoOption := True
  end;

begin
  if ArgsDone or (CParameters = nil) then Exit;
  ArgsDone := True;
  NoSkip := False;
  SkipArgs := False;
  i := 1;
  while (CParamCount > i) and (CStringLComp (CParameters^[i], PrefixOption + '=', Length (PrefixOption) + 1) = 0) do
    begin
      CParamCountSave := CParamCount;
      CParameter1Save := CParameters^[1];
      CParamCount := 2;  { counts from 0! }
      CParameters^[1] := {$local X+} CParameters^[i] + Length (PrefixOption) + 1; {$endlocal}
      ResetGetOpt (1);
      OK := DoOption;
      CParamCount := CParamCountSave;
      CParameters^[1] := CParameter1Save;
      if not OK then
        begin
          WriteLn (StdErr, ParamStr (0), ': invalid RTS option `', CString2String (CParameters^[i]) + '''' + NewLine);
          Help (1)
        end;
      Inc (i)
    end;
  ResetGetOpt (i);
  if (CParamCount > i) and (CStringComp (CParameters^[i], PrefixOption) = 0) then
    repeat
    until not DoOption
  else
    FirstNonOption := i;
  { Make RTS arguments invisible to the program unless the `-s' parameter was given. }
  if SkipArgs and not NoSkip then
    begin
      for i := 1 to CParamCount - FirstNonOption do  { Leave argument #0 as it is. }
        CParameters^[i] := CParameters^[i + FirstNonOption - 1];
      Dec (CParamCount, FirstNonOption - 1)
    end;
  ResetGetOpt (1);
  if InputFile <> nil then
    begin
      Reset (InputFile^);
      CurrentStdIn := InputFile;
      Close (Input);
      Reset (Input)
    end
end;

procedure DoInitProc;
begin
  if InitProc <> nil then InitProc^
end;

procedure InitInit; asmname 'init_GPC_Init';

procedure GPC_Initialize (ArgumentCount: Integer; Arguments, StartEnvironment: PCStrings);
begin
  InitInit;  { @@ call our own initializer }
  CParamCount := ArgumentCount;
  CParameters := Arguments;
  GPC_Init_Environment (GetStartEnvironment (StartEnvironment));
  InitArguments
end;

end.
