fpc/rtl/msxdos/system.pp

unit System;


interface

{$define FPC_IS_SYSTEM}
{ The heap for MSDOS is implemented
  in tinyheap.inc include file,
  but it uses default SysGetMem names }

{$define HAS_MEMORYMANAGER}
{ define TEST_FPU_INT10 to force keeping local int10,
  for testing purpose only }


{$DEFINE FPC_INCLUDE_SOFTWARE_MUL}
{$DEFINE FPC_INCLUDE_SOFTWARE_MOD_DIV}

{$DEFINE FPC_USE_SMALL_DEFAULTSTACKSIZE}
{ To avoid warnings in thread.inc code,
  but value must be really given after
  systemh.inc is included otherwise the
  $mode switch is not effective }

{ Use AnsiChar for files }
{$define FPC_ANSI_TEXTFILEREC}
{$define FPC_STDOUT_TRUE_ALIAS}

{$ifdef NO_WIDESTRINGS}
  { Do NOT use widechar for files }
  {$undef FPC_HAS_FEATURE_WIDESTRINGS}
{$endif NO_WIDESTRINGS}

{$I systemh.inc}
{$I tnyheaph.inc}
{$I portsh.inc}

{$ifndef FPUNONE}
{$ifdef FPC_HAS_FEATURE_SOFTFPU}

{$define fpc_softfpu_interface}
{$i softfpu.pp}
{$undef fpc_softfpu_interface}

{$endif FPC_HAS_FEATURE_SOFTFPU}
{$endif FPUNONE}

const
  LineEnding = #13#10;
  { LFNSupport is a variable here, defined below!!! }
  DirectorySeparator = '\';
  DriveSeparator = ':';
  ExtensionSeparator = '.';
  PathSeparator = ';';
  AllowDirectorySeparators : set of AnsiChar = ['\','/'];
  AllowDriveSeparators : set of AnsiChar = [':'];
  { FileNameCaseSensitive and FileNameCasePreserving are defined separately below!!! }
  maxExitCode = 255;
  MaxPathLen = 256;

const
{ Default filehandles }
  UnusedHandle    = $ffff;{ instead of -1, as it is a word value}
  StdInputHandle  = 0;
  StdOutputHandle = 1;
  { MSX-DOS does not have a separate StdErr }
  StdErrorHandle  = 1;

  FileNameCaseSensitive : boolean = false;
  FileNameCasePreserving: boolean = false;
  CtrlZMarksEOF: boolean = true; (* #26 is considered as end of file *)

  sLineBreak = LineEnding;
  DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;

var
{ Mem[] support }
  mem  : array[0..$7fff-1] of byte absolute $0;
  memw : array[0..($7fff div sizeof(word))-1] of word absolute $0;
  meml : array[0..($7fff div sizeof(longint))-1] of longint absolute $0;
{ C-compatible arguments and environment }
  argc:smallint; //!! public name 'operatingsystem_parameter_argc';
  argv:PPAnsiChar; //!! public name 'operatingsystem_parameter_argv';

{ The DOS Program Segment Prefix segment (TP7 compatibility) }
  PrefixSeg:Word;public name '__fpc_PrefixSeg';

  SaveInt00: FarPointer;public name '__SaveInt00';
  SaveInt10: FarPointer;public name '__SaveInt10';
  SaveInt75: FarPointer;public name '__SaveInt75';
  fpu_status: word;public name '__fpu_status';

const
  AllFilesMask: string [3] = '*.*';

const
  LFNSupport = false;

implementation

procedure DebugWrite(s: PAnsiChar); forward;
procedure DebugWrite(const S: Shortstring); forward;
procedure DebugWriteLn(const S: ShortString); forward;

{$ifdef todo}
const
  { used for an offset fixup for accessing the proc parameters in asm routines
    that use nostackframe. We can't use the parameter name directly, because
    i8086 doesn't support sp relative addressing. }
{$ifdef FPC_X86_CODE_FAR}
  extra_param_offset = 2;
{$else FPC_X86_CODE_FAR}
  extra_param_offset = 0;
{$endif FPC_X86_CODE_FAR}
{$if defined(FPC_X86_DATA_FAR) or defined(FPC_X86_DATA_HUGE)}
  extra_data_offset = 2;
{$else}
  extra_data_offset = 0;
{$endif}

type
  PFarByte = ^Byte;//far;
  PFarChar = ^AnsiChar;//far;
  PFarWord = ^Word;//far;
  PPFarChar = ^PFarChar;
{$endif}

var
  stklen: word; external name '__stklen';

  __heapsize: Word;external name '__heapsize';
  __fpc_initialheap: array[0..0] of byte;external name '__fpc_initialheap';

var
  __stktop : pointer;public name '__stktop';
  dos_version:Word;public name 'dos_version';
  dos_env_count:smallint;public name '__dos_env_count';
  dos_argv0 : PAnsiChar;public name '__fpc_dos_argv0';

{$I registers.inc}

procedure Intr(IntNo: Byte; var Regs: Registers); external name 'FPC_INTR';

procedure MsxDos(var Regs: Registers); assembler; nostackframe; public name 'FPC_MSXDOS';
asm
  //in a, (0x2e)
  { store registers contents }
  push AF
  push BC
  push DE
  push HL
  push IX
  push IY
  { allocate an additional scratch space }
  push IY
  { Regs now resides at SP + 16 }

  { IY is not used for parameters, so base everything on that;
    for that we need to load the address of Regs into IY }
  ld IX, 0x10
  add IX, SP

  ld L,(IX+0)
  ld H,(IX+1)

  push HL
  pop IY

  { fill IX with the help of HL }
  ld L,(IY+8)
  ld H,(IY+9)

  push HL
  pop IX

  ld B,(IY+1)
  ld C,(IY+0)
  ld D,(IY+3)
  ld E,(IY+2)
  // load A last
  //ld A,(IY+4)
  ld H,(IY+7)
  ld L,(IY+6)

  ld A,(IY+4)

  { store IY to scratch location }
  ex (SP),IY

  { call to DOS }
  call 0x0005

  { store IY to scratch and restore pointer address of Regs }
  ex (SP),IY

  ld (IY+1),B
  ld (IY+0),C
  ld (IY+3),D
  ld (IY+2),E
  ld (IY+4),A
  // skip F
  ld (IY+7),H
  ld (IY+6),L

  { store IX with the help of HL }
  push IX
  pop HL
  ld (IY+8),L
  ld (IY+9),H

  { store the stored IY with the help of HL }
  ex (SP),HL

  ld (IY+10),L
  ld (IY+11),H

  { cleanup stack }
  pop IY
  pop IY
  pop IX
  pop HL
  pop DE
  pop BC
  pop AF
end;

procedure InstallInterruptHandlers; external name 'FPC_INSTALL_INTERRUPT_HANDLERS';
procedure RestoreInterruptHandlers; external name 'FPC_RESTORE_INTERRUPT_HANDLERS';

function CheckNullArea: Boolean; external name 'FPC_CHECK_NULLAREA';

{$I system.inc}

{$I tinyheap.inc}

{$I ports.inc}

{$ifndef FPUNONE}
{$ifdef FPC_HAS_FEATURE_SOFTFPU}

{$define fpc_softfpu_implementation}
{$i softfpu.pp}
{$undef fpc_softfpu_implementation}

{ we get these functions and types from the softfpu code }
{$define FPC_SYSTEM_HAS_float64}
{$define FPC_SYSTEM_HAS_float32}
{$define FPC_SYSTEM_HAS_flag}
{$define FPC_SYSTEM_HAS_extractFloat64Frac0}
{$define FPC_SYSTEM_HAS_extractFloat64Frac1}
{$define FPC_SYSTEM_HAS_extractFloat64Exp}
{$define FPC_SYSTEM_HAS_extractFloat64Frac}
{$define FPC_SYSTEM_HAS_extractFloat64Sign}
{$define FPC_SYSTEM_HAS_ExtractFloat32Frac}
{$define FPC_SYSTEM_HAS_extractFloat32Exp}
{$define FPC_SYSTEM_HAS_extractFloat32Sign}

{$endif FPC_HAS_FEATURE_SOFTFPU}
{$endif FPUNONE}

procedure DebugWrite(S: PAnsiChar);
var
  regs: Registers;
begin
  while S^ <> #0 do begin
    regs.C := $02;
    regs.E := Ord(S^);
    MsxDos(regs);
    Inc(S);
  end;
end;

procedure DebugWrite(const S: shortstring);
var
  regs: Registers;
  i: Byte;
begin
  for i := 1 to Length(S) do begin
    regs.C := $02;
    regs.E := Ord(S[i]);
    MsxDos(regs);
  end;
end;

procedure DebugWriteLn(const S: shortstring);
begin
  DebugWrite(S);
  DebugWrite(#13#10);
end;

{*****************************************************************************
                              ParamStr/Randomize
*****************************************************************************}

var
  internal_envp : PPAnsiChar = nil;

procedure setup_environment;
{$ifdef todo}
var
  env_count : smallint;
  cp, dos_env: PFarChar;
{$endif}
begin
{$ifdef todo}
  env_count:=0;
  dos_env:=Ptr(MemW[PrefixSeg:$2C], 0);
  cp:=dos_env;
  while cp^<>#0 do
    begin
      inc(env_count);
      while (cp^ <> #0) do
        inc(cp); { skip to NUL }
      inc(cp); { skip to next character }
    end;
  internal_envp := getmem((env_count+1) * sizeof(PFarChar));
  cp:=dos_env;
  env_count:=0;
  while cp^<>#0 do
    begin
      internal_envp[env_count] := cp;
      inc(env_count);
      while (cp^ <> #0) do
        inc(cp); { skip to NUL }
      inc(cp); { skip to next character }
    end;
  internal_envp[env_count]:=nil;
  dos_env_count := env_count;
  if dos_version >= $300 then
    begin
      if cp=dos_env then
        inc(cp);
      inc(cp, 3);
      dos_argv0 := cp;
    end
  else
    dos_argv0 := nil;
{$endif}
end;

function envp:PPAnsiChar;public name '__fpc_envp';
begin
  if not assigned(internal_envp) then
    setup_environment;
  envp:=internal_envp;
end;

function GetEnvVar(aName: PAnsiChar): ShortString;
var
  regs: Registers;
  i: SizeInt;
begin
  SetLength(Result, 255);
  regs.C := $6B;
  regs.HL := PtrUInt(aName);
  regs.DE := PtrUInt(@Result[1]);
  regs.B := 255;
  regs.A := 0;
  MsxDos(regs);
  if regs.A = 0 then begin
    i := 1;
    aName := PAnsiChar(@Result[1]);
    while i < 256 do begin
      if aName^ = #0 then begin
        SetLength(Result, i);
        Break;
      end;
      Inc(i);
      Inc(aName);
    end;
  end else
    SetLength(Result, 0);
end;

procedure setup_arguments;
var
  i: SmallInt;
  pc: PAnsiChar;
  quote: AnsiChar;
  count: SmallInt;
  arglen, argv0len: SmallInt;
  argblock: PAnsiChar;
  arg: PAnsiChar;
  doscmd   : string[129];  { Dos commandline copied from PSP, max is 128 chars +1 for terminating zero }
  tmp: ShortString;
  regs: Registers;
begin
  tmp := GetEnvVar('PROGRAM');
  argv0len := Length(tmp);

  tmp := GetEnvVar('PARAMETERS');
{$IfDef SYSTEM_DEBUG_STARTUP}
  Writeln(stderr,'Dos command line is #',tmp,'# size = ',length(tmp));
{$EndIf }
  { parse dos commandline }
  pc:=@tmp[1];
  count:=1;
  { calc total arguments length and count }
  arglen:=argv0len+1;
  while pc^<>#0 do
    begin
      { skip leading spaces }
      while pc^ in [#1..#32] do
        inc(pc);
      if pc^=#0 then
        break;
      { calc argument length }
      quote:=' ';
      while (pc^<>#0) do
        begin
          case pc^ of
            #1..#32 :
              begin
                if quote<>' ' then
                  inc(arglen)
                else
                  break;
              end;
            '"' :
              begin
                if quote<>'''' then
                  begin
                    if PAnsiChar(pc+1)^<>'"' then
                      begin
                        if quote='"' then
                          quote:=' '
                        else
                          quote:='"';
                      end
                    else
                     inc(pc);
                  end
                else
                  inc(arglen);
              end;
            '''' :
              begin
                if quote<>'"' then
                  begin
                    if PAnsiChar(pc+1)^<>'''' then
                      begin
                        if quote=''''  then
                         quote:=' '
                        else
                         quote:='''';
                      end
                    else
                      inc(pc);
                  end
                else
                  inc(arglen);
              end;
            else
              inc(arglen);
          end;
          inc(pc);
        end;
      inc(arglen);  { for the null terminator }
      inc(count);
    end;
  Writeln(stderr,'Arg count: ', count, ', size: ', arglen);
  { set argc and allocate argv }
  argc:=count;
  argv:=AllocMem((count+1)*SizeOf(PAnsiChar));
  { allocate a single memory block for all arguments }
  argblock:=GetMem(arglen);
  writeln('Allocated arg vector at ', hexstr(argv), ' and block at ', hexstr(argblock));
  { create argv[0] }
  argv[0]:=argblock;
  arg:=argblock+argv0len;

  arg^:=#0;
  Inc(arg);

  pc:=@tmp[1];
  count:=1;
  while pc^<>#0 do
    begin
      { skip leading spaces }
      while pc^ in [#1..#32] do
        inc(pc);
      if pc^=#0 then
        break;
      { copy argument }
      //writeln('Setting arg ',count,' to ', hexstr(arg));
      asm
        in a,(0x2e)
      end ['a'];
      argv[count]:=arg;
      quote:=' ';
      while (pc^<>#0) do
        begin
          case pc^ of
            #1..#32 :
              begin
                if quote<>' ' then
                  begin
                    arg^:=pc^;
                    inc(arg);
                  end
                else
                  break;
              end;
            '"' :
              begin
                if quote<>'''' then
                  begin
                    if PAnsiChar(pc+1)^<>'"' then
                      begin
                        if quote='"' then
                          quote:=' '
                        else
                          quote:='"';
                      end
                    else
                      inc(pc);
                  end
                else
                  begin
                    arg^:=pc^;
                    inc(arg);
                  end;
              end;
            '''' :
              begin
                if quote<>'"' then
                  begin
                    if PAnsiChar(pc+1)^<>'''' then
                      begin
                        if quote=''''  then
                          quote:=' '
                        else
                          quote:='''';
                      end
                    else
                      inc(pc);
                  end
                else
                  begin
                    arg^:=pc^;
                    inc(arg);
                  end;
              end;
            else
              begin
                arg^:=pc^;
                inc(arg);
              end;
          end;
          inc(pc);
        end;
      arg^:=#0;
      Inc(arg);
 {$IfDef SYSTEM_DEBUG_STARTUP}
      Writeln(stderr,'dos arg ',count,' #',strlen(argv[count]),'#',argv[count],'#');
 {$EndIf SYSTEM_DEBUG_STARTUP}
      inc(count);
    end;

  arg:=argblock;
  tmp:=GetEnvVar('PROGRAM');
  pc:=@tmp[1];
  while pc^ <> #0 do
    begin
      arg^ := pc^;
      Inc(arg);
      Inc(pc);
    end;

  for count:=0 to argc-1 do
    writeln('arg ',count,' at ',hexstr(argv[count]));
end;


function paramcount : longint;
begin
  if argv=nil then
    setup_arguments;
  paramcount := argc - 1;
end;


function paramstr(l : longint) : ShortString;
begin
  if argv=nil then
    setup_arguments;
  if (l>=0) and (l+1<=argc) then
    paramstr:=strpas(argv[l])
  else
    paramstr:='';
end;


procedure randomize;
{$ifdef todo}
var
  hl   : longint;
  regs : Registers;
{$endif}
begin
{$ifdef todo}
  regs.AH:=$2C;
  MsDos(regs);
  hl:=regs.DX;
  randseed:=hl*$10000+ regs.CX;
{$endif}
end;

{*****************************************************************************
                         System Dependent Exit code
*****************************************************************************}

procedure system_exit;
var
  h : byte;
begin
{$ifdef todo}
  RestoreInterruptHandlers;
{$endif}
  for h:=0 to max_files-1 do
    if openfiles[h] then
      begin
{$ifdef SYSTEMDEBUG}
         writeln(stderr,'file ',h,' "',opennames[h],'" not closed at exit');
{$endif SYSTEMDEBUG}
         if h>=5 then
           do_close(h);
      end;
{$ifndef FPC_MM_TINY}
{$ifdef todo}
  if not CheckNullArea then
    writeln(stderr, 'Nil pointer assignment');
{$endif}
{$endif FPC_MM_TINY}
  asm
    ld a, exitcode
    ld b, a
    ld c, 0x62
    call 0x0005
  end;
end;

{*****************************************************************************
                         SystemUnit Initialization
*****************************************************************************}

procedure InitDosHeap;
begin
  RegisterTinyHeapBlock_Simple_Prealigned(@__fpc_initialheap,__heapsize);
end;

procedure SysInitStdIO;
begin
  OpenStdIO(Input,fmInput,StdInputHandle);
  OpenStdIO(Output,fmOutput,StdOutputHandle);
  OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
{$ifndef FPC_STDOUT_TRUE_ALIAS}
  OpenStdIO(StdOut,fmOutput,StdOutputHandle);
  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
{$endif FPC_STDOUT_TRUE_ALIAS}
end;

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

function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt;
begin
  result := stklen;
end;

procedure InitDosVersion;
var
  regs: Registers;
begin
  regs.C := $6F;
  regs.A := 0;
  MsxDos(regs);
  if regs.A <> 0 then
    dos_version := 0
  else if regs.B < 2 then
    dos_version := $100
  else
    dos_version := regs.DE;
end;

begin
  StackLength := stklen;
  StackBottom := __stktop - stklen;
  InitDosVersion;
  { for now we don't support MSX-DOS 1 }
  if dos_version < $100 then
    Halt($85);
{$ifdef todo}
  InstallInterruptHandlers;
{$endif}
  { To be set if this is a GUI or console application }
  IsConsole := TRUE;
{$ifdef FPC_HAS_FEATURE_DYNLIBS}
  { If dynlibs feature is disabled,
    IsLibrary is a constant, which can thus not be set to a value }
  { To be set if this is a library and not a program  }
  IsLibrary := FALSE;
{$endif def FPC_HAS_FEATURE_DYNLIBS}
{ Setup heap }
  InitDosHeap;
  SysInitExceptions;
{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
  initunicodestringmanager;
{$endif def FPC_HAS_FEATURE_UNICODESTRINGS}
{ Setup stdin, stdout and stderr }
  SysInitStdIO;
{ Setup environment and arguments }
  { Done on  request only Setup_Environment; }
  { Done on request only Setup_Arguments; }
{ Reset IO Error }
  InOutRes:=0;
{$ifdef FPC_HAS_FEATURE_THREADING}
  InitSystemThreads;
{$endif}
end.