kolibrios-fun/programs/develop/fp/rtl/system.pp

{utf8}
unit System;

{$i _defines.inc}
{$define HAS_CMDLINE}

interface

{$i systemh.inc}
{$i kos_def.inc}
{$i kosh.inc}

const
  LineEnding = #13#10;
  LFNSupport = True;
  DirectorySeparator = '/';
  DriveSeparator = '/';
  PathSeparator = ';';
  MaxExitCode = 65535;
  MaxPathLen = 512;

  InitialStkLen = 20480; /// siemargl



  UnusedHandle   : THandle = -1;
  StdInputHandle : THandle = 0;
  StdOutputHandle: THandle = 0;
  StdErrorHandle : THandle = 0;
  FileNameCaseSensitive: Boolean = True;
  CtrlZMarksEOF: Boolean = True;
  sLineBreak = LineEnding;
  DefaultTextLineBreakStyle: TTextLineBreakStyle = tlbsCRLF;

var
  Argc: Longint = 0;
  Argv: PPChar = nil;

  Konsole: TKonsole;


implementation

var
  SysInstance: Longint; public name '_FPC_SysInstance';

{$i system.inc}


procedure SetupCmdLine;
var
  Ptrs: array of PChar;
  Args: PChar;
  InQuotes: Boolean;
  I, L: Longint;
begin
  Argc := 1;
  Args := PKosHeader(0)^.args;
  if Assigned(Args) then
  begin
    while Args^ <> #0 do
    begin
      {Пропустить лидирующие пробелы}
      while Args^ in [#1..#32] do Inc(Args);
      if Args^ = #0 then Break;

      {Запомнить указатель на параметр}
      SetLength(Ptrs, Argc);
      Ptrs[Argc - 1] := Args;
      Inc(Argc);

      {Пропустить текущий параметр}
      InQuotes := False;
      while (Args^ <> #0) and (not (Args^ in [#1..#32]) or InQuotes) do
      begin
        if Args^ = '"' then InQuotes := not InQuotes;
        Inc(Args);
      end;

      {Установить окончание параметра}
      if Args^ in [#1..#32] then
      begin
        Args^ := #0;
        Inc(Args);
      end;
    end;
  end;
  Argv := GetMem(Argc * SizeOf(PChar));  {XXX: память не освобождается}
  Argv[0] :=  PKosHeader(0)^.path;
  for I := 1 to Argc - 1 do
  begin
    Argv[I] := Ptrs[I - 1];
    {Исключить кавычки из строки}
    Args := Argv[I];
    L := 0;
    while Args^ <> #0 do begin Inc(Args); Inc(L); end;
    Args := Argv[I];
    while Args^ <> #0 do
    begin
      if Args^ = '"' then
      begin
        Move(PChar(Args + 1)^, Args^, L);
        Dec(L);
      end;
      Inc(Args);
      Dec(L);
    end;
  end;
end;

function ParamCount: Longint;
begin
  Result := Argc - 1;
end;

function ParamStr(L: Longint): String;
begin
  if (L >= 0) and (L < Argc) then
    Result := StrPas(Argv[L]) else
    Result := '';
end;

procedure Randomize;
begin
  randseed := kos_timecounter();
end;

const
  ProcessID: SizeUInt = 0;

function GetProcessID: SizeUInt;
begin
  GetProcessID := ProcessID;
end;

function CheckInitialStkLen(stklen: SizeUInt): SizeUInt;
begin
  {TODO}
  Result := stklen;
end;

{$i kos_stdio.inc}

procedure SysInitStdIO;
begin
  if IsConsole then
  begin
    AssignStdin(Input);
    AssignStdout(Output);
    AssignStdout(ErrOutput);
    AssignStdout(StdOut);
    AssignStdout(StdErr);
  end;
end;

procedure System_Exit; [public, alias: 'SystemExit'];
var
  event, count: DWord;
begin
  if IsConsole then
  begin
    if ExitCode <> 0 then
    begin
      {XXX: обязательное условие на однопоточный Konsole}
      Write(StdErr, '[Error #', ExitCode,', press any key]');
      {ожидать нажатия клавиши}
      Konsole.KeyPressed;
      while Konsole.KeyPressed = 0 do kos_delay(2);
      {TODO: исправить косяк при перерисовке Konsole}
      {это невозможно, так как куча освобождается еще до вызова этой процедуры}
      {можно написать свой диспетчер памяти, но это сложно}
      {а если в Konsole использовать выделение памяти напрямую через KosAPI?!}
    end;
    Close(StdErr);
    Close(StdOut);
    Close(ErrOutput);
    Close(Input);
    Close(Output);
    Konsole.Done();
  end;
  asm
    movl $-1, %eax
    int $0x40
  end;
end;

{$i kos.inc}

begin
  SysResetFPU;
  StackLength := CheckInitialStkLen(InitialStkLen);
  StackBottom := Pointer(StackTop - StackLength);
  kos_initheap();
  InitHeap;
  SysInitExceptions;
  FPC_CpuCodeInit();
  InOutRes := 0;
  InitSystemThreads;
  if IsConsole then
    Konsole.Init();
  SysInitStdIO;
  SetupCmdLine;
  InitVariantManager;
  {InitWideStringManager;}
  DispCallByIDProc := @DoDispCallByIDError;
end.