* added initial watcom extender files; they need to be cleaned up

rtl/watcom/crt.pp

@@ -0,0 +1,815 @@
+unit crt;
+interface
+
+const
+{ CRT modes }
+  BW40          = 0;            { 40x25 B/W on Color Adapter }
+  CO40          = 1;            { 40x25 Color on Color Adapter }
+  BW80          = 2;            { 80x25 B/W on Color Adapter }
+  CO80          = 3;            { 80x25 Color on Color Adapter }
+  Mono          = 7;            { 80x25 on Monochrome Adapter }
+  Font8x8       = 256;          { Add-in for ROM font }
+
+{ Mode constants for 3.0 compatibility }
+  C40           = CO40;
+  C80           = CO80;
+
+{ Foreground and background color constants }
+  Black         = 0;
+  Blue          = 1;
+  Green         = 2;
+  Cyan          = 3;
+  Red           = 4;
+  Magenta       = 5;
+  Brown         = 6;
+  LightGray     = 7;
+
+{ Foreground color constants }
+  DarkGray      = 8;
+  LightBlue     = 9;
+  LightGreen    = 10;
+  LightCyan     = 11;
+  LightRed      = 12;
+  LightMagenta  = 13;
+  Yellow        = 14;
+  White         = 15;
+
+{ Add-in for blinking }
+  Blink         = 128;
+
+var
+
+{ Interface variables }
+  CheckBreak: Boolean;    { Enable Ctrl-Break }
+  CheckEOF: Boolean;      { Enable Ctrl-Z }
+  DirectVideo: Boolean;   { Enable direct video addressing }
+  CheckSnow: Boolean;     { Enable snow filtering }
+  LastMode: Word;         { Current text mode }
+  TextAttr: Byte;         { Current text attribute }
+  WindMin: Word;          { Window upper left coordinates }
+  WindMax: Word;          { Window lower right coordinates }
+
+{ Interface procedures }
+procedure AssignCrt(var F: Text);
+function KeyPressed: Boolean;
+function ReadKey: Char;
+procedure TextMode(Mode: Integer);
+procedure Window(X1,Y1,X2,Y2: Byte);
+procedure GotoXY(X,Y: Byte);
+function WhereX: Byte;
+function WhereY: Byte;
+procedure ClrScr;
+procedure ClrEol;
+procedure InsLine;
+procedure DelLine;
+procedure TextColor(Color: Byte);
+procedure TextBackground(Color: Byte);
+procedure LowVideo;
+procedure HighVideo;
+procedure NormVideo;
+procedure Delay(MS: Word);
+procedure Sound(Hz: Word);
+procedure NoSound;
+
+{Extra Functions}
+procedure cursoron;
+procedure cursoroff;
+procedure cursorbig;
+
+
+implementation
+
+uses
+  watcom;
+
+
+{$ASMMODE ATT}
+
+var
+  DelayCnt,
+  ScreenWidth,
+  ScreenHeight : longint;
+  VidSeg : Word;
+
+{
+  definition of textrec is in textrec.inc
+}
+{$i textrec.inc}
+
+
+{****************************************************************************
+                           Low level Routines
+****************************************************************************}
+
+procedure setscreenmode(mode : byte);
+var
+  regs : trealregs;
+begin
+  regs.realeax:=mode;
+  realintr($10,regs);
+end;
+
+
+function GetScreenHeight : longint;
+begin
+  getscreenheight:=mem[$40:$84]+1;
+  If mem[$40:$84]=0 then
+    getscreenheight := 25;
+end;
+
+
+function GetScreenWidth : longint;
+begin
+  getscreenwidth:=memw[$40:$4a];
+end;
+
+
+procedure SetScreenCursor(x,y : longint);
+var
+  regs : trealregs;
+begin
+  regs.realeax:=$0200;
+  regs.realebx:=0;
+  regs.realedx:=(y-1) shl 8+(x-1);
+  realintr($10,regs);
+end;
+
+
+procedure GetScreenCursor(var x,y : longint);
+begin
+  x:=mem[$40:$50]+1;
+  y:=mem[$40:$51]+1;
+end;
+
+
+{****************************************************************************
+                              Helper Routines
+****************************************************************************}
+
+Function WinMinX: Byte;
+{
+  Current Minimum X coordinate
+}
+Begin
+  WinMinX:=(WindMin and $ff)+1;
+End;
+
+
+
+Function WinMinY: Byte;
+{
+  Current Minimum Y Coordinate
+}
+Begin
+  WinMinY:=(WindMin shr 8)+1;
+End;
+
+
+
+Function WinMaxX: Byte;
+{
+  Current Maximum X coordinate
+}
+Begin
+  WinMaxX:=(WindMax and $ff)+1;
+End;
+
+
+
+Function WinMaxY: Byte;
+{
+  Current Maximum Y coordinate;
+}
+Begin
+  WinMaxY:=(WindMax shr 8) + 1;
+End;
+
+
+
+Function FullWin:boolean;
+{
+  Full Screen 80x25? Window(1,1,80,25) is used, allows faster routines
+}
+begin
+  FullWin:=(WinMinX=1) and (WinMinY=1) and
+           (WinMaxX=ScreenWidth) and (WinMaxY=ScreenHeight);
+end;
+
+
+{****************************************************************************
+                             Public Crt Functions
+****************************************************************************}
+
+
+procedure textmode(mode : integer);
+
+var
+   regs : trealregs;
+
+begin
+  lastmode:=mode;
+  mode:=mode and $ff;
+  setscreenmode(mode);
+
+  { set 8x8 font }
+  if (lastmode and $100)<>0 then
+    begin
+       regs.realeax:=$1112;
+       regs.realebx:=$0;
+       realintr($10,regs);
+    end;
+
+  screenwidth:=getscreenwidth;
+  screenheight:=getscreenheight;
+  windmin:=0;
+  windmax:=(screenwidth-1) or ((screenheight-1) shl 8);
+end;
+
+
+Procedure TextColor(Color: Byte);
+{
+  Switch foregroundcolor
+}
+Begin
+  TextAttr:=(Color and $f) or (TextAttr and $70);
+  If (Color>15) Then TextAttr:=TextAttr Or Blink;
+End;
+
+
+
+Procedure TextBackground(Color: Byte);
+{
+  Switch backgroundcolor
+}
+Begin
+  TextAttr:=((Color shl 4) and ($f0 and not Blink)) or (TextAttr and ($0f OR Blink) );
+End;
+
+
+
+Procedure HighVideo;
+{
+  Set highlighted output.
+}
+Begin
+  TextColor(TextAttr Or $08);
+End;
+
+
+
+Procedure LowVideo;
+{
+  Set normal output
+}
+Begin
+  TextColor(TextAttr And $77);
+End;
+
+
+
+Procedure NormVideo;
+{
+  Set normal back and foregroundcolors.
+}
+Begin
+  TextColor(7);
+  TextBackGround(0);
+End;
+
+
+Procedure GotoXy(X: Byte; Y: Byte);
+{
+  Go to coordinates X,Y in the current window.
+}
+Begin
+  If (X>0) and (X<=WinMaxX- WinMinX+1) and
+     (Y>0) and (Y<=WinMaxY-WinMinY+1) Then
+   Begin
+     Inc(X,WinMinX-1);
+     Inc(Y,WinMinY-1);
+     SetScreenCursor(x,y);
+   End;
+End;
+
+
+Procedure Window(X1, Y1, X2, Y2: Byte);
+{
+  Set screen window to the specified coordinates.
+}
+Begin
+  if (X1>X2) or (X2>ScreenWidth) or
+     (Y1>Y2) or (Y2>ScreenHeight) then
+   exit;
+  WindMin:=((Y1-1) Shl 8)+(X1-1);
+  WindMax:=((Y2-1) Shl 8)+(X2-1);
+  GoToXY(1,1);
+End;
+
+
+Procedure ClrScr;
+{
+  Clear the current window, and set the cursor on 1,1
+}
+var
+  fil : word;
+  y   : longint;
+begin
+  fil:=32 or (textattr shl 8);
+  if FullWin then
+   DosmemFillWord(VidSeg,0,ScreenHeight*ScreenWidth,fil)
+  else
+   begin
+     for y:=WinMinY to WinMaxY do
+      DosmemFillWord(VidSeg,((y-1)*ScreenWidth+(WinMinX-1))*2,WinMaxX-WinMinX+1,fil);
+   end;
+  Gotoxy(1,1);
+end;
+
+
+Procedure ClrEol;
+{
+  Clear from current position to end of line.
+}
+var
+  x,y : longint;
+  fil : word;
+Begin
+  GetScreenCursor(x,y);
+  fil:=32 or (textattr shl 8);
+  if x<=WinMaxX then
+   DosmemFillword(VidSeg,((y-1)*ScreenWidth+(x-1))*2,WinMaxX-x+1,fil);
+End;
+
+
+
+Function WhereX: Byte;
+{
+  Return current X-position of cursor.
+}
+var
+  x,y : longint;
+Begin
+  GetScreenCursor(x,y);
+  WhereX:=x-WinMinX+1;
+End;
+
+
+
+Function WhereY: Byte;
+{
+  Return current Y-position of cursor.
+}
+var
+  x,y : longint;
+Begin
+  GetScreenCursor(x,y);
+  WhereY:=y-WinMinY+1;
+End;
+
+
+{*************************************************************************
+                            KeyBoard
+*************************************************************************}
+
+var
+   is_last : boolean;
+   last    : char;
+
+function readkey : char;
+var
+  char2 : char;
+  char1 : char;
+  regs : trealregs;
+begin
+  if is_last then
+   begin
+     is_last:=false;
+     readkey:=last;
+   end
+  else
+   begin
+     regs.ah:=$10;
+     realintr($16,regs);
+     if (regs.al=$e0) and (regs.ah<>0) then
+      regs.al:=0;
+     char1:=chr(regs.al);
+     char2:=chr(regs.ah);
+     if char1=#0 then
+      begin
+        is_last:=true;
+        last:=char2;
+      end;
+     readkey:=char1;
+   end;
+end;
+
+
+function keypressed : boolean;
+var
+  regs : trealregs;
+begin
+  if is_last then
+   begin
+     keypressed:=true;
+     exit;
+   end
+  else
+   begin
+     regs.ah:=$11;
+     realintr($16,regs);
+     keypressed:=((regs.realflags and zeroflag) = 0);
+   end;
+end;
+
+
+{*************************************************************************
+                                   Delay
+*************************************************************************}
+
+procedure Delayloop;assembler;
+asm
+.LDelayLoop1:
+        subl    $1,%eax
+        jc      .LDelayLoop2
+        cmpl    %fs:(%edi),%ebx
+        je      .LDelayLoop1
+.LDelayLoop2:
+end;
+
+
+procedure initdelay;assembler;
+asm
+        { for some reason, using int $31/ax=$901 doesn't work here }
+        { and interrupts are always disabled at this point when    }
+        { running a program inside gdb(pas). Web bug 1345 (JM)     }
+        sti
+        movl    $0x46c,%edi
+        movl    $-28,%edx
+        movl    %fs:(%edi),%ebx
+.LInitDel1:
+        cmpl    %fs:(%edi),%ebx
+        je      .LInitDel1
+        movl    %fs:(%edi),%ebx
+        movl    %edx,%eax
+        call    DelayLoop
+
+        notl    %eax
+        xorl    %edx,%edx
+        movl    $55,%ecx
+        divl    %ecx
+        movl    %eax,DelayCnt
+end;
+
+
+procedure Delay(MS: Word);assembler;
+asm
+        movzwl  MS,%ecx
+        jecxz   .LDelay2
+        movl    $0x400,%edi
+        movl    DelayCnt,%edx
+        movl    %fs:(%edi),%ebx
+.LDelay1:
+        movl    %edx,%eax
+        call    DelayLoop
+        loop    .LDelay1
+.LDelay2:
+end;
+
+
+procedure sound(hz : word);
+begin
+  if hz=0 then
+   begin
+     nosound;
+     exit;
+   end;
+  asm
+        movzwl  hz,%ecx
+        movl    $1193046,%eax
+        cltd
+        divl    %ecx
+        movl    %eax,%ecx
+        inb     $0x61,%al
+        testb   $0x3,%al
+        jnz     .Lsound_next
+        orb     $0x3,%al
+        outb    %al,$0x61
+        movb    $0xb6,%al
+        outb    %al,$0x43
+     .Lsound_next:
+        movb    %cl,%al
+        outb    %al,$0x42
+        movb    %ch,%al
+        outb    %al,$0x42
+  end ['EAX','ECX','EDX'];
+end;
+
+
+procedure nosound;
+begin
+  asm
+        inb     $0x61,%al
+        andb    $0xfc,%al
+        outb    %al,$0x61
+  end ['EAX'];
+end;
+
+
+
+{****************************************************************************
+                          HighLevel Crt Functions
+****************************************************************************}
+
+procedure removeline(y : longint);
+var
+  fil : word;
+begin
+  fil:=32 or (textattr shl 8);
+  y:=WinMinY+y-1;
+  While (y<WinMaxY) do
+   begin
+     dosmemmove(VidSeg,(y*ScreenWidth+(WinMinX-1))*2,
+                VidSeg,((y-1)*ScreenWidth+(WinMinX-1))*2,(WinMaxX-WinMinX+1)*2);
+     inc(y);
+   end;
+  dosmemfillword(VidSeg,((WinMaxY-1)*ScreenWidth+(WinMinX-1))*2,(WinMaxX-WinMinX+1),fil);
+end;
+
+
+procedure delline;
+begin
+  removeline(wherey);
+end;
+
+
+procedure insline;
+var
+  my,y : longint;
+  fil : word;
+begin
+  fil:=32 or (textattr shl 8);
+  y:=WhereY;
+  my:=WinMaxY-WinMinY;
+  while (my>=y) do
+   begin
+     dosmemmove(VidSeg,(((WinMinY+my-1)-1)*ScreenWidth+(WinMinX-1))*2,
+                VidSeg,(((WinMinY+my)-1)*ScreenWidth+(WinMinX-1))*2,(WinMaxX-WinMinX+1)*2);
+     dec(my);
+   end;
+  dosmemfillword(VidSeg,(((WinMinY+y-1)-1)*ScreenWidth+(WinMinX-1))*2,(WinMaxX-WinMinX+1),fil);
+end;
+
+
+
+
+{****************************************************************************
+                             Extra Crt Functions
+****************************************************************************}
+
+procedure cursoron;
+var
+  regs : trealregs;
+begin
+  regs.realeax:=$0100;
+  regs.realecx:=$90A;
+  If VidSeg=$b800 then
+    regs.realecx:=$90A
+  else
+    regs.realecx:=$b0d;
+  realintr($10,regs);
+end;
+
+
+procedure cursoroff;
+var
+  regs : trealregs;
+begin
+  regs.realeax:=$0100;
+  regs.realecx:=$ffff;
+  realintr($10,regs);
+end;
+
+
+procedure cursorbig;
+var
+  regs : trealregs;
+begin
+  regs.realeax:=$0100;
+  regs.realecx:=$10A;
+  realintr($10,regs);
+end;
+
+
+{*****************************************************************************
+                          Read and Write routines
+*****************************************************************************}
+
+var
+  CurrX,CurrY : longint;
+
+Procedure WriteChar(c:char);
+var
+  regs : trealregs;
+begin
+  case c of
+   #10 : inc(CurrY);
+   #13 : CurrX:=WinMinX;
+    #8 : begin
+           if CurrX>WinMinX then
+            dec(CurrX);
+         end;
+    #7 : begin { beep }
+           regs.dl:=7;
+           regs.ah:=2;
+           realintr($21,regs);
+         end;
+  else
+   begin
+     memw[VidSeg:((CurrY-1)*ScreenWidth+(CurrX-1))*2]:=(textattr shl 8) or byte(c);
+     inc(CurrX);
+   end;
+  end;
+  if CurrX>WinMaxX then
+   begin
+     CurrX:=WinMinX;
+     inc(CurrY);
+   end;
+  while CurrY>WinMaxY do
+   begin
+     removeline(1);
+     dec(CurrY);
+   end;
+end;
+
+
+Function CrtWrite(var f : textrec):integer;
+var
+  i : longint;
+begin
+  GetScreenCursor(CurrX,CurrY);
+  for i:=0 to f.bufpos-1 do
+   WriteChar(f.buffer[i]);
+  SetScreenCursor(CurrX,CurrY);
+  f.bufpos:=0;
+  CrtWrite:=0;
+end;
+
+
+Function CrtRead(Var F: TextRec): Integer;
+
+  procedure BackSpace;
+  begin
+    if (f.bufpos>0) and (f.bufpos=f.bufend) then
+     begin
+       WriteChar(#8);
+       WriteChar(' ');
+       WriteChar(#8);
+       dec(f.bufpos);
+       dec(f.bufend);
+     end;
+  end;
+
+var
+  ch : Char;
+Begin
+  GetScreenCursor(CurrX,CurrY);
+  f.bufpos:=0;
+  f.bufend:=0;
+  repeat
+    if f.bufpos>f.bufend then
+     f.bufend:=f.bufpos;
+    SetScreenCursor(CurrX,CurrY);
+    ch:=readkey;
+    case ch of
+    #0 : case readkey of
+          #71 : while f.bufpos>0 do
+                 begin
+                   dec(f.bufpos);
+                   WriteChar(#8);
+                 end;
+          #75 : if f.bufpos>0 then
+                 begin
+                   dec(f.bufpos);
+                   WriteChar(#8);
+                 end;
+          #77 : if f.bufpos<f.bufend then
+                 begin
+                   WriteChar(f.bufptr^[f.bufpos]);
+                   inc(f.bufpos);
+                 end;
+          #79 : while f.bufpos<f.bufend do
+                 begin
+                   WriteChar(f.bufptr^[f.bufpos]);
+                   inc(f.bufpos);
+                 end;
+         end;
+    ^S,
+    #8 : BackSpace;
+    ^Y,
+   #27 : begin
+           f.bufpos:=f.bufend;
+           while f.bufend>0 do
+            BackSpace;
+         end;
+   #13 : begin
+           WriteChar(#13);
+           WriteChar(#10);
+           f.bufptr^[f.bufend]:=#13;
+           f.bufptr^[f.bufend+1]:=#10;
+           inc(f.bufend,2);
+           break;
+         end;
+   #26 : if CheckEOF then
+          begin
+            f.bufptr^[f.bufend]:=#26;
+            inc(f.bufend);
+            break;
+          end;
+    else
+     begin
+       if f.bufpos<f.bufsize-2 then
+        begin
+          f.buffer[f.bufpos]:=ch;
+          inc(f.bufpos);
+          WriteChar(ch);
+        end;
+     end;
+    end;
+  until false;
+  f.bufpos:=0;
+  SetScreenCursor(CurrX,CurrY);
+  CrtRead:=0;
+End;
+
+
+Function CrtReturn(Var F: TextRec): Integer;
+Begin
+  CrtReturn:=0;
+end;
+
+
+Function CrtClose(Var F: TextRec): Integer;
+Begin
+  F.Mode:=fmClosed;
+  CrtClose:=0;
+End;
+
+
+Function CrtOpen(Var F: TextRec): Integer;
+Begin
+  If F.Mode=fmOutput Then
+   begin
+     TextRec(F).InOutFunc:=@CrtWrite;
+     TextRec(F).FlushFunc:=@CrtWrite;
+   end
+  Else
+   begin
+     F.Mode:=fmInput;
+     TextRec(F).InOutFunc:=@CrtRead;
+     TextRec(F).FlushFunc:=@CrtReturn;
+   end;
+  TextRec(F).CloseFunc:=@CrtClose;
+  CrtOpen:=0;
+End;
+
+
+procedure AssignCrt(var F: Text);
+begin
+  Assign(F,'');
+  TextRec(F).OpenFunc:=@CrtOpen;
+end;
+
+{ use the C version to avoid using dpmiexcp unit
+  which makes sysutils and exceptions working incorrectly  PM }
+
+//function __djgpp_set_ctrl_c(enable : longint) : boolean;cdecl;external;
+
+var
+  x,y : longint;
+begin
+{ Load startup values }
+  ScreenWidth:=GetScreenWidth;
+  ScreenHeight:=GetScreenHeight;
+  WindMax:=(ScreenWidth-1) or ((ScreenHeight-1) shl 8);
+{ Load TextAttr }
+  GetScreenCursor(x,y);
+  lastmode := mem[$40:$49];
+  if screenheight>25 then
+    lastmode:=lastmode or $100;
+  If not(lastmode=Mono) then
+    VidSeg := $b800
+  else
+    VidSeg := $b000;
+  TextAttr:=mem[VidSeg:((y-1)*ScreenWidth+(x-1))*2+1];
+{ Redirect the standard output }
+  assigncrt(Output);
+  Rewrite(Output);
+  TextRec(Output).Handle:=StdOutputHandle;
+  assigncrt(Input);
+  Reset(Input);
+  TextRec(Input).Handle:=StdInputHandle;
+{ Calculates delay calibration }
+  initdelay;
+{ Enable ctrl-c input (JM) }
+//  __djgpp_set_ctrl_c(0);
+end.

rtl/watcom/dos.pp

@@ -0,0 +1,1160 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by the Free Pascal development team.
+
+    Dos unit for BP7 compatible RTL
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program 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.
+
+ **********************************************************************}
+unit dos;
+interface
+
+Uses
+  Watcom;
+
+
+Const
+  {Bitmasks for CPU Flags}
+  fcarry     = $0001;
+  fparity    = $0004;
+  fauxiliary = $0010;
+  fzero      = $0040;
+  fsign      = $0080;
+  foverflow  = $0800;
+
+  {Bitmasks for file attribute}
+  readonly  = $01;
+  hidden    = $02;
+  sysfile   = $04;
+  volumeid  = $08;
+  directory = $10;
+  archive   = $20;
+  anyfile   = $3F;
+
+  {File Status}
+  fmclosed = $D7B0;
+  fminput  = $D7B1;
+  fmoutput = $D7B2;
+  fminout  = $D7B3;
+
+
+Type
+{ Needed for LFN Support }
+  ComStr  = String[255];
+  PathStr = String[255];
+  DirStr  = String[255];
+  NameStr = String[255];
+  ExtStr  = String[255];
+
+{
+  filerec.inc contains the definition of the filerec.
+  textrec.inc contains the definition of the textrec.
+  It is in a separate file to make it available in other units without
+  having to use the DOS unit for it.
+}
+{$i filerec.inc}
+{$i textrec.inc}
+
+  DateTime = packed record
+    Year,
+    Month,
+    Day,
+    Hour,
+    Min,
+    Sec   : word;
+  End;
+
+  searchrec = packed record
+     fill : array[1..21] of byte;
+     attr : byte;
+     time : longint;
+     { reserved : word; not in DJGPP V2 }
+     size : longint;
+     name : string[255]; { LFN Name, DJGPP uses only [12] but more can't hurt (PFV) }
+  end;
+
+  Registers = Watcom.Registers;
+
+Var
+  DosError : integer;
+
+{Interrupt}
+Procedure Intr(intno: byte; var regs: registers);
+Procedure MSDos(var regs: registers);
+
+{Info/Date/Time}
+Function  DosVersion: Word;
+Procedure GetDate(var year, month, mday, wday: word);
+Procedure GetTime(var hour, minute, second, sec100: word);
+procedure SetDate(year,month,day: word);
+Procedure SetTime(hour,minute,second,sec100: word);
+Procedure UnpackTime(p: longint; var t: datetime);
+Procedure PackTime(var t: datetime; var p: longint);
+
+{Exec}
+Procedure Exec(const path: pathstr; const comline: comstr);
+Function  DosExitCode: word;
+
+{Disk}
+Function  DiskFree(drive: byte) : int64;
+Function  DiskSize(drive: byte) : int64;
+Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
+Procedure FindNext(var f: searchRec);
+Procedure FindClose(Var f: SearchRec);
+
+{File}
+Procedure GetFAttr(var f; var attr: word);
+Procedure GetFTime(var f; var time: longint);
+Function  FSearch(path: pathstr; dirlist: string): pathstr;
+Function  FExpand(const path: pathstr): pathstr;
+Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
+function  GetShortName(var p : String) : boolean;
+function  GetLongName(var p : String) : boolean;
+
+{Environment}
+Function  EnvCount: longint;
+Function  EnvStr(index: integer): string;
+Function  GetEnv(envvar: string): string;
+
+{Misc}
+Procedure SetFAttr(var f; attr: word);
+Procedure SetFTime(var f; time: longint);
+Procedure GetCBreak(var breakvalue: boolean);
+Procedure SetCBreak(breakvalue: boolean);
+Procedure GetVerify(var verify: boolean);
+Procedure SetVerify(verify: boolean);
+
+{Do Nothing Functions}
+Procedure SwapVectors;
+Procedure GetIntVec(intno: byte; var vector: pointer);
+Procedure SetIntVec(intno: byte; vector: pointer);
+Procedure Keep(exitcode: word);
+
+
+implementation
+
+uses
+  strings;
+
+{$ASMMODE ATT}
+
+{******************************************************************************
+                           --- Dos Interrupt ---
+******************************************************************************}
+
+var
+  dosregs : registers;
+
+procedure LoadDosError;
+var
+  r : registers;
+  SimpleDosError : word;
+begin
+  if (dosregs.flags and fcarry) <> 0 then
+   begin
+     { I got a extended error = 0
+       while CarryFlag was set from Exec function }
+     SimpleDosError:=dosregs.ax;
+     r.eax:=$5900;
+     r.ebx:=$0;
+     realintr($21,r);
+     { conversion from word to integer !!
+       gave a Bound check error if ax is $FFFF !! PM }
+     doserror:=integer(r.ax);
+     case doserror of
+      0  : DosError:=integer(SimpleDosError);
+      19 : DosError:=150;
+      21 : DosError:=152;
+     end;
+   end
+  else
+    doserror:=0;
+end;
+
+
+procedure intr(intno : byte;var regs : registers);
+begin
+  realintr(intno,regs);
+end;
+
+
+procedure msdos(var regs : registers);
+begin
+  intr($21,regs);
+end;
+
+
+{******************************************************************************
+                        --- Info / Date / Time ---
+******************************************************************************}
+
+function dosversion : word;
+begin
+  dosregs.ax:=$3000;
+  msdos(dosregs);
+  dosversion:=dosregs.ax;
+end;
+
+
+procedure getdate(var year,month,mday,wday : word);
+begin
+  dosregs.ax:=$2a00;
+  msdos(dosregs);
+  wday:=dosregs.al;
+  year:=dosregs.cx;
+  month:=dosregs.dh;
+  mday:=dosregs.dl;
+end;
+
+
+procedure setdate(year,month,day : word);
+begin
+   dosregs.cx:=year;
+   dosregs.dh:=month;
+   dosregs.dl:=day;
+   dosregs.ah:=$2b;
+   msdos(dosregs);
+end;
+
+
+procedure gettime(var hour,minute,second,sec100 : word);
+begin
+  dosregs.ah:=$2c;
+  msdos(dosregs);
+  hour:=dosregs.ch;
+  minute:=dosregs.cl;
+  second:=dosregs.dh;
+  sec100:=dosregs.dl;
+end;
+
+
+procedure settime(hour,minute,second,sec100 : word);
+begin
+  dosregs.ch:=hour;
+  dosregs.cl:=minute;
+  dosregs.dh:=second;
+  dosregs.dl:=sec100;
+  dosregs.ah:=$2d;
+  msdos(dosregs);
+end;
+
+
+Procedure packtime(var t : datetime;var p : longint);
+Begin
+  p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
+End;
+
+
+Procedure unpacktime(p : longint;var t : datetime);
+Begin
+  with t do
+   begin
+     sec:=(p and 31) shl 1;
+     min:=(p shr 5) and 63;
+     hour:=(p shr 11) and 31;
+     day:=(p shr 16) and 31;
+     month:=(p shr 21) and 15;
+     year:=(p shr 25)+1980;
+   end;
+End;
+
+
+{******************************************************************************
+                               --- Exec ---
+******************************************************************************}
+
+var
+  lastdosexitcode : word;
+
+procedure exec(const path : pathstr;const comline : comstr);
+type
+  realptr = packed record
+    ofs,seg : word;
+  end;
+  texecblock = packed record
+    envseg    : word;
+    comtail   : realptr;
+    firstFCB  : realptr;
+    secondFCB : realptr;
+    iniStack  : realptr;
+    iniCSIP   : realptr;
+  end;
+var
+  current_dos_buffer_pos,
+  arg_ofs,
+  i,la_env,
+  la_p,la_c,la_e,
+  fcb1_la,fcb2_la : longint;
+  execblock       : texecblock;
+  c,p             : string;
+
+  function paste_to_dos(src : string) : boolean;
+  var
+    c : array[0..255] of char;
+  begin
+     paste_to_dos:=false;
+     if current_dos_buffer_pos+length(src)+1>transfer_buffer+tb_size then
+      RunError(217);
+     move(src[1],c[0],length(src));
+     c[length(src)]:=#0;
+     seg_move(get_ds,longint(@c),dosmemselector,current_dos_buffer_pos,length(src)+1);
+     current_dos_buffer_pos:=current_dos_buffer_pos+length(src)+1;
+     paste_to_dos:=true;
+  end;
+
+begin
+{ create command line }
+  move(comline[0],c[1],length(comline)+1);
+  c[length(comline)+2]:=#13;
+  c[0]:=char(length(comline)+2);
+{ create path }
+  p:=path;
+  for i:=1 to length(p) do
+   if p[i]='/' then
+    p[i]:='\';
+  if LFNSupport then
+    GetShortName(p);
+{ create buffer }
+  la_env:=transfer_buffer;
+  while (la_env and 15)<>0 do
+   inc(la_env);
+  current_dos_buffer_pos:=la_env;
+{ copy environment }
+  for i:=1 to envcount do
+   paste_to_dos(envstr(i));
+  paste_to_dos(''); { adds a double zero at the end }
+{ allow slash as backslash }
+  la_p:=current_dos_buffer_pos;
+  paste_to_dos(p);
+  la_c:=current_dos_buffer_pos;
+  paste_to_dos(c);
+  la_e:=current_dos_buffer_pos;
+  fcb1_la:=la_e;
+  la_e:=la_e+16;
+  fcb2_la:=la_e;
+  la_e:=la_e+16;
+{ allocate FCB see dosexec code }
+  arg_ofs:=1;
+  while (c[arg_ofs] in [' ',#9]) do
+   inc(arg_ofs);
+  dosregs.ax:=$2901;
+  dosregs.ds:=(la_c+arg_ofs) shr 4;
+  dosregs.esi:=(la_c+arg_ofs) and 15;
+  dosregs.es:=fcb1_la shr 4;
+  dosregs.edi:=fcb1_la and 15;
+  msdos(dosregs);
+{ allocate second FCB see dosexec code }
+  repeat
+    inc(arg_ofs);
+  until (c[arg_ofs] in [' ',#9,#13]);
+  if c[arg_ofs]<>#13 then
+   begin
+     repeat
+       inc(arg_ofs);
+     until not (c[arg_ofs] in [' ',#9]);
+   end;
+  dosregs.ax:=$2901;
+  dosregs.ds:=(la_c+arg_ofs) shr 4;
+  dosregs.si:=(la_c+arg_ofs) and 15;
+  dosregs.es:=fcb2_la shr 4;
+  dosregs.di:=fcb2_la and 15;
+  msdos(dosregs);
+  with execblock do
+   begin
+     envseg:=la_env shr 4;
+     comtail.seg:=la_c shr 4;
+     comtail.ofs:=la_c and 15;
+     firstFCB.seg:=fcb1_la shr 4;
+     firstFCB.ofs:=fcb1_la and 15;
+     secondFCB.seg:=fcb2_la shr 4;
+     secondFCB.ofs:=fcb2_la and 15;
+   end;
+  seg_move(get_ds,longint(@execblock),dosmemselector,la_e,sizeof(texecblock));
+  dosregs.edx:=la_p and 15;
+  dosregs.ds:=la_p shr 4;
+  dosregs.ebx:=la_e and 15;
+  dosregs.es:=la_e shr 4;
+  dosregs.ax:=$4b00;
+  msdos(dosregs);
+  LoadDosError;
+  if DosError=0 then
+   begin
+     dosregs.ax:=$4d00;
+     msdos(dosregs);
+     LastDosExitCode:=DosRegs.al
+   end
+  else
+   LastDosExitCode:=0;
+end;
+
+
+function dosexitcode : word;
+begin
+  dosexitcode:=lastdosexitcode;
+end;
+
+
+procedure getcbreak(var breakvalue : boolean);
+begin
+  dosregs.ax:=$3300;
+  msdos(dosregs);
+  breakvalue:=dosregs.dl<>0;
+end;
+
+
+procedure setcbreak(breakvalue : boolean);
+begin
+  dosregs.ax:=$3301;
+  dosregs.dl:=ord(breakvalue);
+  msdos(dosregs);
+end;
+
+
+procedure getverify(var verify : boolean);
+begin
+  dosregs.ah:=$54;
+  msdos(dosregs);
+  verify:=dosregs.al<>0;
+end;
+
+
+procedure setverify(verify : boolean);
+begin
+  dosregs.ah:=$2e;
+  dosregs.al:=ord(verify);
+  msdos(dosregs);
+end;
+
+
+{******************************************************************************
+                               --- Disk ---
+******************************************************************************}
+
+
+TYPE  ExtendedFat32FreeSpaceRec=packed Record
+         RetSize           : WORD; { (ret) size of returned structure}
+         Strucversion      : WORD; {(call) structure version (0000h)
+                                    (ret) actual structure version (0000h)}
+         SecPerClus,               {number of sectors per cluster}
+         BytePerSec,               {number of bytes per sector}
+         AvailClusters,            {number of available clusters}
+         TotalClusters,            {total number of clusters on the drive}
+         AvailPhysSect,            {physical sectors available on the drive}
+         TotalPhysSect,            {total physical sectors on the drive}
+         AvailAllocUnits,          {Available allocation units}
+         TotalAllocUnits : DWORD;  {Total allocation units}
+         Dummy,Dummy2    : DWORD;  {8 bytes reserved}
+         END;
+
+function do_diskdata(drive : byte; Free : BOOLEAN) : Int64;
+VAR
+  S    : String;
+  Rec  : ExtendedFat32FreeSpaceRec;
+BEGIN
+ if (swap(dosversion)>=$070A) AND LFNSupport then
+  begin
+   S:='C:\'#0;
+   if Drive=0 then
+    begin
+     GetDir(Drive,S);
+     Setlength(S,4);
+     S[4]:=#0;
+    end
+   else
+    S[1]:=chr(Drive+64);
+   Rec.Strucversion:=0;
+   dosmemput(tb_segment,tb_offset,Rec,SIZEOF(ExtendedFat32FreeSpaceRec));
+   dosmemput(tb_segment,tb_offset+Sizeof(ExtendedFat32FreeSpaceRec)+1,S[1],4);
+   dosregs.dx:=tb_offset+Sizeof(ExtendedFat32FreeSpaceRec)+1;
+   dosregs.ds:=tb_segment;
+   dosregs.di:=tb_offset;
+   dosregs.es:=tb_segment;
+   dosregs.cx:=Sizeof(ExtendedFat32FreeSpaceRec);
+   dosregs.ax:=$7303;
+   msdos(dosregs);
+   if (dosregs.flags and fcarry) = 0 then {No error clausule in int except cf}
+    begin
+      copyfromdos(rec,Sizeof(ExtendedFat32FreeSpaceRec));
+      if Free then
+       Do_DiskData:=int64(rec.AvailAllocUnits)*rec.SecPerClus*rec.BytePerSec
+      else
+       Do_DiskData:=int64(rec.TotalAllocUnits)*rec.SecPerClus*rec.BytePerSec;
+    end
+   else
+    Do_DiskData:=-1;
+  end
+ else
+  begin
+   dosregs.dl:=drive;
+   dosregs.ah:=$36;
+   msdos(dosregs);
+   if dosregs.ax<>$FFFF then
+    begin
+     if Free then
+      Do_DiskData:=int64(dosregs.ax)*dosregs.bx*dosregs.cx
+     else
+      Do_DiskData:=int64(dosregs.ax)*dosregs.cx*dosregs.dx;
+    end
+   else
+    do_diskdata:=-1;
+  end;
+end;
+
+function diskfree(drive : byte) : int64;
+begin
+   diskfree:=Do_DiskData(drive,TRUE);
+end;
+
+
+function disksize(drive : byte) : int64;
+begin
+  disksize:=Do_DiskData(drive,false);
+end;
+
+
+{******************************************************************************
+                      --- LFNFindfirst LFNFindNext ---
+******************************************************************************}
+
+type
+  LFNSearchRec=packed record
+    attr,
+    crtime,
+    crtimehi,
+    actime,
+    actimehi,
+    lmtime,
+    lmtimehi,
+    sizehi,
+    size      : longint;
+    reserved  : array[0..7] of byte;
+    name      : array[0..259] of byte;
+    shortname : array[0..13] of byte;
+  end;
+
+procedure LFNSearchRec2Dos(const w:LFNSearchRec;hdl:longint;var d:Searchrec;from_findfirst : boolean);
+var
+  Len : longint;
+begin
+  With w do
+   begin
+     FillChar(d,sizeof(SearchRec),0);
+     if DosError=0 then
+      len:=StrLen(@Name)
+     else
+      len:=0;
+     d.Name[0]:=chr(len);
+     Move(Name[0],d.Name[1],Len);
+     d.Time:=lmTime;
+     d.Size:=Size;
+     d.Attr:=Attr and $FF;
+     if (DosError<>0) and from_findfirst then
+       hdl:=-1;
+     Move(hdl,d.Fill,4);
+   end;
+end;
+
+
+procedure LFNFindFirst(path:pchar;attr:longint;var s:searchrec);
+var
+  i : longint;
+  w : LFNSearchRec;
+begin
+  { allow slash as backslash }
+  for i:=0 to strlen(path) do
+    if path[i]='/' then path[i]:='\';
+  dosregs.si:=1; { use ms-dos time }
+  { don't include the label if not asked for it, needed for network drives }
+  if attr=$8 then
+   dosregs.ecx:=8
+  else
+   dosregs.ecx:=attr and (not 8);
+  dosregs.edx:=tb_offset+Sizeof(LFNSearchrec)+1;
+  dosmemput(tb_segment,tb_offset+Sizeof(LFNSearchrec)+1,path^,strlen(path)+1);
+  dosregs.ds:=tb_segment;
+  dosregs.edi:=tb_offset;
+  dosregs.es:=tb_segment;
+  dosregs.ax:=$714e;
+  msdos(dosregs);
+  LoadDosError;
+  copyfromdos(w,sizeof(LFNSearchRec));
+  LFNSearchRec2Dos(w,dosregs.ax,s,true);
+end;
+
+
+procedure LFNFindNext(var s:searchrec);
+var
+  hdl : longint;
+  w   : LFNSearchRec;
+begin
+  Move(s.Fill,hdl,4);
+  dosregs.si:=1; { use ms-dos time }
+  dosregs.edi:=tb_offset;
+  dosregs.es:=tb_segment;
+  dosregs.ebx:=hdl;
+  dosregs.ax:=$714f;
+  msdos(dosregs);
+  LoadDosError;
+  copyfromdos(w,sizeof(LFNSearchRec));
+  LFNSearchRec2Dos(w,hdl,s,false);
+end;
+
+
+procedure LFNFindClose(var s:searchrec);
+var
+  hdl : longint;
+begin
+  Move(s.Fill,hdl,4);
+  { Do not call MsDos if FindFirst returned with an error }
+  if hdl=-1 then
+    begin
+      DosError:=0;
+      exit;
+    end;
+  dosregs.ebx:=hdl;
+  dosregs.ax:=$71a1;
+  msdos(dosregs);
+  LoadDosError;
+end;
+
+
+{******************************************************************************
+                     --- DosFindfirst DosFindNext ---
+******************************************************************************}
+
+procedure dossearchrec2searchrec(var f : searchrec);
+var
+  len : longint;
+begin
+  { Check is necessary!! OS/2's VDM doesn't clear the name with #0 if the }
+  { file doesn't exist! (JM)                                              }
+  if dosError = 0 then
+    len:=StrLen(@f.Name)
+  else len := 0;
+  Move(f.Name[0],f.Name[1],Len);
+  f.Name[0]:=chr(len);
+end;
+
+
+procedure DosFindfirst(path : pchar;attr : word;var f : searchrec);
+var
+   i : longint;
+begin
+  { allow slash as backslash }
+  for i:=0 to strlen(path) do
+    if path[i]='/' then path[i]:='\';
+  copytodos(f,sizeof(searchrec));
+  dosregs.edx:=tb_offset;
+  dosregs.ds:=tb_segment;
+  dosregs.ah:=$1a;
+  msdos(dosregs);
+  dosregs.ecx:=attr;
+  dosregs.edx:=tb_offset+Sizeof(searchrec)+1;
+  dosmemput(tb_segment,tb_offset+Sizeof(searchrec)+1,path^,strlen(path)+1);
+  dosregs.ds:=tb_segment;
+  dosregs.ah:=$4e;
+  msdos(dosregs);
+  copyfromdos(f,sizeof(searchrec));
+  LoadDosError;
+  dossearchrec2searchrec(f);
+end;
+
+
+procedure Dosfindnext(var f : searchrec);
+begin
+  copytodos(f,sizeof(searchrec));
+  dosregs.edx:=tb_offset;
+  dosregs.ds:=tb_segment;
+  dosregs.ah:=$1a;
+  msdos(dosregs);
+  dosregs.ah:=$4f;
+  msdos(dosregs);
+  copyfromdos(f,sizeof(searchrec));
+  LoadDosError;
+  dossearchrec2searchrec(f);
+end;
+
+
+{******************************************************************************
+                     --- Findfirst FindNext ---
+******************************************************************************}
+
+procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
+var
+  path0 : array[0..256] of char;
+begin
+  doserror:=0;
+  strpcopy(path0,path);
+  if LFNSupport then
+   LFNFindFirst(path0,attr,f)
+  else
+   Dosfindfirst(path0,attr,f);
+end;
+
+
+procedure findnext(var f : searchRec);
+begin
+  doserror:=0;
+  if LFNSupport then
+   LFNFindnext(f)
+  else
+   Dosfindnext(f);
+end;
+
+
+Procedure FindClose(Var f: SearchRec);
+begin
+  DosError:=0;
+  if LFNSupport then
+   LFNFindClose(f);
+end;
+
+
+type swap_proc = procedure;
+
+//var
+//  _swap_in  : swap_proc;external name '_swap_in';
+//  _swap_out : swap_proc;external name '_swap_out';
+//  _exception_exit : pointer;external name '_exception_exit';
+//  _v2prt0_exceptions_on : longbool;external name '_v2prt0_exceptions_on';
+
+procedure swapvectors;
+begin
+(*  if _exception_exit<>nil then
+    if _v2prt0_exceptions_on then
+      _swap_out()
+    else
+      _swap_in();*)
+end;
+
+
+{******************************************************************************
+                               --- File ---
+******************************************************************************}
+
+procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
+var
+   dotpos,p1,i : longint;
+begin
+  { allow slash as backslash }
+  for i:=1 to length(path) do
+   if path[i]='/' then path[i]:='\';
+  { get drive name }
+  p1:=pos(':',path);
+  if p1>0 then
+    begin
+       dir:=path[1]+':';
+       delete(path,1,p1);
+    end
+  else
+    dir:='';
+  { split the path and the name, there are no more path informtions }
+  { if path contains no backslashes                                 }
+  while true do
+    begin
+       p1:=pos('\',path);
+       if p1=0 then
+         break;
+       dir:=dir+copy(path,1,p1);
+       delete(path,1,p1);
+    end;
+  { try to find out a extension }
+  if LFNSupport then
+    begin
+       Ext:='';
+       i:=Length(Path);
+       DotPos:=256;
+       While (i>0) Do
+         Begin
+            If (Path[i]='.') Then
+              begin
+                 DotPos:=i;
+                 break;
+              end;
+            Dec(i);
+         end;
+       Ext:=Copy(Path,DotPos,255);
+       Name:=Copy(Path,1,DotPos - 1);
+    end
+  else
+    begin
+       p1:=pos('.',path);
+       if p1>0 then
+         begin
+            ext:=copy(path,p1,4);
+            delete(path,p1,length(path)-p1+1);
+         end
+       else
+         ext:='';
+       name:=path;
+    end;
+end;
+
+
+(*
+function FExpand (const Path: PathStr): PathStr;
+- declared in fexpand.inc
+*)
+
+{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
+{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
+
+{$I fexpand.inc}
+
+{$UNDEF FPC_FEXPAND_DRIVES}
+{$UNDEF FPC_FEXPAND_UNC}
+
+
+Function FSearch(path: pathstr; dirlist: string): pathstr;
+var
+  i,p1   : longint;
+  s      : searchrec;
+  newdir : pathstr;
+begin
+{ check if the file specified exists }
+  findfirst(path,anyfile,s);
+  if doserror=0 then
+   begin
+     findclose(s);
+     fsearch:=path;
+     exit;
+   end;
+{ No wildcards allowed in these things }
+  if (pos('?',path)<>0) or (pos('*',path)<>0) then
+    fsearch:=''
+  else
+    begin
+       { allow slash as backslash }
+       for i:=1 to length(dirlist) do
+         if dirlist[i]='/' then dirlist[i]:='\';
+       repeat
+         p1:=pos(';',dirlist);
+         if p1<>0 then
+          begin
+            newdir:=copy(dirlist,1,p1-1);
+            delete(dirlist,1,p1);
+          end
+         else
+          begin
+            newdir:=dirlist;
+            dirlist:='';
+          end;
+         if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
+          newdir:=newdir+'\';
+         findfirst(newdir+path,anyfile,s);
+         if doserror=0 then
+          newdir:=newdir+path
+         else
+          newdir:='';
+       until (dirlist='') or (newdir<>'');
+       fsearch:=newdir;
+    end;
+  findclose(s);
+end;
+
+
+{ change to short filename if successful DOS call PM }
+function GetShortName(var p : String) : boolean;
+var
+  c : array[0..255] of char;
+begin
+  move(p[1],c[0],length(p));
+  c[length(p)]:=#0;
+  copytodos(c,length(p)+1);
+  dosregs.ax:=$7160;
+  dosregs.cx:=1;
+  dosregs.ds:=tb_segment;
+  dosregs.si:=tb_offset;
+  dosregs.es:=tb_segment;
+  dosregs.di:=tb_offset;
+  msdos(dosregs);
+  LoadDosError;
+  if DosError=0 then
+   begin
+     copyfromdos(c,255);
+     move(c[0],p[1],strlen(c));
+     p[0]:=char(strlen(c));
+     GetShortName:=true;
+   end
+  else
+   GetShortName:=false;
+end;
+
+
+{ change to long filename if successful DOS call PM }
+function GetLongName(var p : String) : boolean;
+var
+  c : array[0..255] of char;
+begin
+  move(p[1],c[0],length(p));
+  c[length(p)]:=#0;
+  copytodos(c,length(p)+1);
+  dosregs.ax:=$7160;
+  dosregs.cx:=2;
+  dosregs.ds:=tb_segment;
+  dosregs.si:=tb_offset;
+  dosregs.es:=tb_segment;
+  dosregs.di:=tb_offset;
+  msdos(dosregs);
+  LoadDosError;
+  if DosError=0 then
+   begin
+     copyfromdos(c,255);
+     move(c[0],p[1],strlen(c));
+     p[0]:=char(strlen(c));
+     GetLongName:=true;
+   end
+  else
+   GetLongName:=false;
+end;
+
+
+{******************************************************************************
+                       --- Get/Set File Time,Attr ---
+******************************************************************************}
+
+procedure getftime(var f;var time : longint);
+begin
+  dosregs.bx:=textrec(f).handle;
+  dosregs.ax:=$5700;
+  msdos(dosregs);
+  loaddoserror;
+  time:=(dosregs.dx shl 16)+dosregs.cx;
+end;
+
+
+procedure setftime(var f;time : longint);
+begin
+  dosregs.bx:=textrec(f).handle;
+  dosregs.cx:=time and $ffff;
+  dosregs.dx:=time shr 16;
+  dosregs.ax:=$5701;
+  msdos(dosregs);
+  loaddoserror;
+end;
+
+
+procedure getfattr(var f;var attr : word);
+begin
+  copytodos(filerec(f).name,strlen(filerec(f).name)+1);
+  dosregs.edx:=tb_offset;
+  dosregs.ds:=tb_segment;
+  if LFNSupport then
+   begin
+     dosregs.ax:=$7143;
+     dosregs.bx:=0;
+   end
+  else
+   dosregs.ax:=$4300;
+  msdos(dosregs);
+  LoadDosError;
+  Attr:=dosregs.cx;
+end;
+
+
+procedure setfattr(var f;attr : word);
+begin
+  copytodos(filerec(f).name,strlen(filerec(f).name)+1);
+  dosregs.edx:=tb_offset;
+  dosregs.ds:=tb_segment;
+  if LFNSupport then
+   begin
+     dosregs.ax:=$7143;
+     dosregs.bx:=1;
+   end
+  else
+   dosregs.ax:=$4301;
+  dosregs.cx:=attr;
+  msdos(dosregs);
+  LoadDosError;
+end;
+
+
+{******************************************************************************
+                             --- Environment ---
+******************************************************************************}
+
+function envcount : longint;
+var
+  hp : ppchar;
+begin
+  hp:=envp;
+  envcount:=0;
+  while assigned(hp^) do
+   begin
+     inc(envcount);
+     inc(hp);
+   end;
+end;
+
+
+function envstr(index : integer) : string;
+begin
+  if (index<=0) or (index>envcount) then
+   begin
+     envstr:='';
+     exit;
+   end;
+  envstr:=strpas(ppchar(pointer(envp)+4*(index-1))^);
+end;
+
+
+Function  GetEnv(envvar: string): string;
+var
+  hp      : ppchar;
+  hs    : string;
+  eqpos : longint;
+begin
+  envvar:=upcase(envvar);
+  hp:=envp;
+  getenv:='';
+  while assigned(hp^) do
+   begin
+     hs:=strpas(hp^);
+     eqpos:=pos('=',hs);
+     if upcase(copy(hs,1,eqpos-1))=envvar then
+      begin
+        getenv:=copy(hs,eqpos+1,255);
+        exit;
+      end;
+     inc(hp);
+   end;
+end;
+
+
+{******************************************************************************
+                             --- Not Supported ---
+******************************************************************************}
+
+Procedure keep(exitcode : word);
+Begin
+End;
+
+Procedure getintvec(intno : byte;var vector : pointer);
+Begin
+End;
+
+Procedure setintvec(intno : byte;vector : pointer);
+Begin
+End;
+
+
+end.
+{
+  $Log$
+  Revision 1.1  2003-09-05 18:09:35  florian
+    * added initial watcom extender files; they need to be cleaned up
+
+  Revision 1.1.2.16  2001/11/23 00:17:42  carl
+  * Compatible with documentation
+  - remove int64
+
+  Revision 1.1.2.15  2001/10/04 11:23:22  pierre
+   * fix failure check for do_diskdata with LFN support
+
+  Revision 1.1.2.14  2001/06/13 22:13:15  hajny
+    * universal FExpand merged
+
+  Revision 1.1.2.13  2001/06/06 11:05:27  pierre
+   * correct SwapVectors behavior
+
+  Revision 1.1.2.12  2000/12/16 15:34:28  peter
+    * fixed disksize return -1 for error
+
+  Revision 1.1.2.11  2000/10/11 15:38:17  peter
+    * diskfree doserror fix
+
+  Revision 1.1.2.10  2000/09/22 10:09:42  pierre
+   * fix LFN handle problem if FindFirst fails
+
+  Revision 1.1.2.9  2000/09/22 08:42:51  pierre
+   * fix wrong DiskSize report
+
+  Revision 1.1.2.8  2000/09/06 20:46:18  peter
+    * removed previous fsplit() patch as it's not the correct behaviour for
+      LFNs. The code showing the bug could easily be adapted
+
+  Revision 1.1.2.7  2000/09/04 20:15:22  peter
+    * fixed previous commit
+
+  Revision 1.1.2.6  2000/09/04 19:36:24  peter
+    * fsplit with .. fix from Thomas
+
+  Revision 1.1.2.5  2000/08/04 21:40:25  peter
+    * getenv is case insentive, needed for windir and winbootdir envs
+
+  Revision 1.1.2.4  2000/08/02 19:34:14  peter
+    * more doserror fixes
+
+  Revision 1.1.2.3  2000/07/30 17:06:23  peter
+    * removed dos lf
+
+  Revision 1.1.2.2  2000/07/30 16:35:44  peter
+    * don't set doserror in gettime/settime/getdate/setdate, tp compatible
+
+  Revision 1.1.2.1  2000/07/22 12:21:30  jonas
+    * fixed buffer overrun error in dossearchrec2searchrec when a file
+      is not found (at least it happened in OS/2's VDM)
+
+  Revision 1.1  2000/07/13 06:30:35  michael
+  + Initial import
+
+  Revision 1.24  2000/05/30 04:41:05  jonas
+    * fixed compiling problem with formal expression passed as var
+      parameter
+
+  Revision 1.23  2000/03/22 08:00:42  pierre
+   + allow double backslash for network drives
+
+  Revision 1.22  2000/02/09 16:59:28  peter
+    * truncated log
+
+  Revision 1.21  2000/02/09 13:00:32  peter
+    + getlongname
+
+  Revision 1.20  2000/02/02 17:34:49  pierre
+   * use int64 typecast to avoid overflows in diskfree and disksize
+
+  Revision 1.19  2000/01/23 16:31:23  peter
+    * hasint64diskspace define changed to int64 so it's default now
+
+  Revision 1.18  2000/01/23 12:28:38  marco
+   * Added diskfree and disksize with AH=71 dos functions (LFN/Fat32)
+
+  Revision 1.17  2000/01/07 16:41:30  daniel
+    * copyright 2000
+
+  Revision 1.16  2000/01/07 16:32:23  daniel
+    * copyright 2000 added
+
+  Revision 1.15  1999/12/06 18:26:49  peter
+    * fpcmake updated for win32 commandline
+
+  Revision 1.14  1999/11/09 11:07:50  pierre
+    * SwapVectors does not reset DosError anymore
+    + DosError is set to ax regsiter value if extended doserror function
+      retruns zero.
+    + Support for LFN in EXEC function using
+      function 7160 to get short filename counterpart
+
+  Revision 1.13  1999/11/06 14:38:23  peter
+    * truncated log
+
+  Revision 1.12  1999/09/10 17:14:09  peter
+    * better errorcode returning using int21h,5900
+
+  Revision 1.11  1999/09/08 18:55:49  peter
+    * pointer fixes
+
+  Revision 1.10  1999/08/13 21:23:15  peter
+    * fsearch checks first if the specified file exists and returns that
+      if it was found
+
+}

rtl/watcom/mc.bat

@@ -0,0 +1,4 @@
+:: make crt
+
+@echo off
+ppc386 crt.pas -Twatcom -Fic:\pp\source\rtl\inc -Fic:\pp\source\rtl\i386 -di386

rtl/watcom/mdos.bat

@@ -0,0 +1,4 @@
+:: make dos
+
+@echo off
+ppc386.exe dos.pp -Twatcom -Fic:\pp\source\rtl\inc -Fic:\pp\source\rtl\i386 -di386

rtl/watcom/mo.bat

@@ -0,0 +1,3 @@
+:: make objects
+
+ppc386 objpas.pas -n -Twatcom -Fic:\pp\source\rtl\inc -Fic:\pp\source\rtl\i386 -di386 -dNO_EXCEPTIONS_IN_SYSTEM

rtl/watcom/mp.bat

@@ -0,0 +1,3 @@
+:: make prt0
+
+wasm prt0.asm -bt=dos -3s -fp3 -ms -zq

rtl/watcom/ms.bat

@@ -0,0 +1,3 @@
+:: make system
+
+ppc386 syswat.pas -Us -n -Twatcom -Fic:\pp\source\rtl\inc -Fic:\pp\source\rtl\i386 -di386 -dNO_EXCEPTIONS_IN_SYSTEM

rtl/watcom/objpas.pp

@@ -0,0 +1,8 @@
+unit objpas;
+
+{ DUMMY - exceptions to do }
+
+interface
+implementation
+
+end.

rtl/watcom/prt0.asm

@@ -0,0 +1,51 @@
+
+ ;  to do: command line, environment
+
+
+.387
+.386p
+
+	name cstart
+	assume nothing
+	extrn PASCALMAIN : near
+	public _cstart_
+	public ___exit
+	public ___sbrk
+
+.STACK 1000h
+.CODE
+
+_cstart_ proc near
+        	jmp     short main
+        	db      "WATCOM"
+	main:
+		push	ds
+		pop	es
+		push	ds
+		pop	fs
+        	call    PASCALMAIN
+_cstart_ endp
+
+___exit proc near
+		pop	eax
+		mov	ah,4Ch
+		int	21h
+___exit endp
+
+___sbrk proc near
+		mov	ebx,dword ptr [esp+4]
+		mov	ecx,ebx
+		shr	ebx,16
+		mov	ax,501h
+		int	31h
+		jnc	sbrk_ok
+		mov	eax,-1
+		ret
+	sbrk_ok:
+		shl	ebx,16
+		mov	bx,cx
+		mov	eax,ebx
+		ret
+___sbrk endp
+
+end _cstart_

rtl/watcom/system.pp

@@ -0,0 +1,1177 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by the Free Pascal development team.
+ 
+    Watcom
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program 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.
+
+ **********************************************************************}
+
+unit syswat;
+
+INTERFACE
+
+{$ifndef NO_EXCEPTIONS_IN_SYSTEM}
+{$define EXCEPTIONS_IN_SYSTEM}
+{$endif NO_EXCEPTIONS_IN_SYSTEM}
+
+{ include system-independent routine headers }
+
+{$include systemh.inc}
+
+{ include heap support headers }
+
+
+{$include heaph.inc}
+
+{Platform specific information}
+const
+ LineEnding = #13#10;
+{ LFNSupport is a variable here, defined below!!! }
+ DirectorySeparator = '\';
+ DriveSeparator = ':';
+ PathSeparator = ';';
+{ FileNameCaseSensitive is defined separately below!!! }
+
+const
+{ Default filehandles }
+  UnusedHandle    = -1;
+  StdInputHandle  = 0;
+  StdOutputHandle = 1;
+  StdErrorHandle  = 2;
+
+  FileNameCaseSensitive : boolean = false;
+
+{ Default memory segments (Tp7 compatibility) }
+  seg0040 = $0040;
+  segA000 = $A000;
+  segB000 = $B000;
+  segB800 = $B800;
+
+var
+{ Mem[] support }
+  mem  : array[0..$7fffffff] of byte absolute $0:$0;
+  memw : array[0..$7fffffff] of word absolute $0:$0;
+  meml : array[0..$7fffffff] of longint absolute $0:$0;
+{ C-compatible arguments and environment }
+  argc  : longint;
+  argv  : ppchar;
+  envp  : ppchar;
+  dos_argv0 : pchar;
+
+{$ifndef RTLLITE}
+{ System info }
+  LFNSupport : boolean;
+{$ELSE RTLLITE}
+Const
+  LFNSupport = false;
+{$endif RTLLITE}
+
+{
+  necessary for objects.pas, should be removed (at least from the interface
+  to the implementation)
+}
+  type
+    trealregs=record
+      realedi,realesi,realebp,realres,
+      realebx,realedx,realecx,realeax : longint;
+      realflags,
+      reales,realds,realfs,realgs,
+      realip,realcs,realsp,realss  : word;
+    end;
+  function  do_write(h,addr,len : longint) : longint;
+  function  do_read(h,addr,len : longint) : longint;
+  procedure syscopyfromdos(addr : longint; len : longint);
+  procedure syscopytodos(addr : longint; len : longint);
+  procedure sysrealintr(intnr : word;var regs : trealregs);
+
+  var tb:longint;
+      transfer_buffer:longint absolute tb;
+      tb_segment:word;
+
+  const tb_offset=0;
+        tb_size=8192;      
+
+IMPLEMENTATION
+
+{ include system independent routines }
+
+{$include system.inc}
+
+
+const
+  carryflag = 1;
+
+type
+  tseginfo=packed record
+    offset  : pointer;
+    segment : word;
+  end;
+
+{$ifndef EXCEPTIONS_IN_SYSTEM}
+var
+  old_int00 : tseginfo;cvar;
+  old_int75 : tseginfo;cvar;
+{$endif ndef EXCEPTIONS_IN_SYSTEM}
+
+{$asmmode ATT}
+
+{*****************************************************************************
+                             Watcom Helpers
+*****************************************************************************}
+
+function far_strlen(selector : word;linear_address : longint) : longint;assembler;
+asm
+        movl linear_address,%edx
+        movl %edx,%ecx
+        movw selector,%gs
+.Larg19:
+        movb %gs:(%edx),%al
+        testb %al,%al
+        je .Larg20
+        incl %edx
+        jmp .Larg19
+.Larg20:
+        movl %edx,%eax
+        subl %ecx,%eax
+end;
+
+
+function get_ds : word;assembler;
+asm
+        movw    %ds,%ax
+end;
+
+
+function get_cs : word;assembler;
+asm
+        movw    %cs,%ax
+end;
+
+function dos_selector : word; assembler;
+asm
+   movw %ds,%ax  { no separate selector needed }
+end;
+
+procedure alloc_tb; assembler;
+{ allocate 8kB real mode transfer buffer }
+asm
+   movw $0x100,%ax
+   movw $512,%bx
+   int $0x31
+   movw %ax,tb_segment
+   shll $16,%eax
+   shrl $12,%eax
+   movl %eax,tb
+end;
+
+procedure sysseg_move(sseg : word;source : longint;dseg : word;dest : longint;count : longint);
+begin
+   if count=0 then
+     exit;
+   if (sseg<>dseg) or ((sseg=dseg) and (source>dest)) then
+     asm
+        pushw %es
+        pushw %ds
+        cld
+        movl count,%ecx
+        movl source,%esi
+        movl dest,%edi
+        movw dseg,%ax
+        movw %ax,%es
+        movw sseg,%ax
+        movw %ax,%ds
+        movl %ecx,%eax
+        shrl $2,%ecx
+        rep
+        movsl
+        movl %eax,%ecx
+        andl $3,%ecx
+        rep
+        movsb
+        popw %ds
+        popw %es
+     end ['ESI','EDI','ECX','EAX']
+   else if (source<dest) then
+     { copy backward for overlapping }
+     asm
+        pushw %es
+        pushw %ds
+        std
+        movl count,%ecx
+        movl source,%esi
+        movl dest,%edi
+        movw dseg,%ax
+        movw %ax,%es
+        movw sseg,%ax
+        movw %ax,%ds
+        addl %ecx,%esi
+        addl %ecx,%edi
+        movl %ecx,%eax
+        andl $3,%ecx
+        orl %ecx,%ecx
+        jz .LSEG_MOVE1
+
+        { calculate esi and edi}
+        decl %esi
+        decl %edi
+        rep
+        movsb
+        incl %esi
+        incl %edi
+     .LSEG_MOVE1:
+        subl $4,%esi
+        subl $4,%edi
+        movl %eax,%ecx
+        shrl $2,%ecx
+        rep
+        movsl
+        cld
+        popw %ds
+        popw %es
+     end ['ESI','EDI','ECX'];
+end;
+
+
+var
+  _args : ppchar;//###########external name '_args';
+
+procedure setup_arguments;
+begin
+ // ####################################
+end;
+
+
+
+function strcopy(dest,source : pchar) : pchar;
+begin
+  asm
+        cld
+        movl 12(%ebp),%edi
+        movl $0xffffffff,%ecx
+        xorb %al,%al
+        repne
+        scasb
+        not %ecx
+        movl 8(%ebp),%edi
+        movl 12(%ebp),%esi
+        movl %ecx,%eax
+        shrl $2,%ecx
+        rep
+        movsl
+        movl %eax,%ecx
+        andl $3,%ecx
+        rep
+        movsb
+        movl 8(%ebp),%eax
+        leave
+        ret $8
+  end;
+end;
+
+
+procedure setup_environment;
+begin
+ //#########################3
+end;
+
+procedure syscopytodos(addr : longint; len : longint);
+begin
+   if len > tb_size then
+     HandleError(217);
+   sysseg_move(get_ds,addr,dos_selector,tb,len);
+end;
+
+
+procedure syscopyfromdos(addr : longint; len : longint);
+begin
+   if len > tb_size then
+     HandleError(217);
+   sysseg_move(dos_selector,tb,get_ds,addr,len);
+end;
+
+
+procedure sysrealintr(intnr : word;var regs : trealregs);
+begin
+   regs.realsp:=0;
+   regs.realss:=0;
+   asm
+      pushw %fs
+      movw  intnr,%bx
+      xorl  %ecx,%ecx
+      movl  regs,%edi
+      movw  $0x300,%ax
+      int   $0x31
+      popw  %fs
+   end;
+end;
+
+
+procedure set_pm_interrupt(vector : byte;const intaddr : tseginfo);
+begin
+  asm
+        movl intaddr,%eax
+        movl (%eax),%edx
+        movw 4(%eax),%cx
+        movl $0x205,%eax
+        movb vector,%bl
+        int $0x31
+  end;
+end;
+
+
+procedure get_pm_interrupt(vector : byte;var intaddr : tseginfo);
+begin
+  asm
+        movb    vector,%bl
+        movl    $0x204,%eax
+        int     $0x31
+        movl    intaddr,%eax
+        movl    %edx,(%eax)
+        movw    %cx,4(%eax)
+  end;
+end;
+
+
+procedure getinoutres(def : word);
+var
+  regs : trealregs;
+begin
+  regs.realeax:=$5900;
+  regs.realebx:=$0;
+  sysrealintr($21,regs);
+  InOutRes:=lo(regs.realeax);
+  case InOutRes of
+   19 : InOutRes:=150;
+   21 : InOutRes:=152;
+   32 : InOutRes:=5;
+  end;
+  if InOutRes=0 then
+    InOutRes:=Def;
+end;
+
+
+   { Keep Track of open files }
+   const
+      max_files = 50;
+   var
+      openfiles : array [0..max_files-1] of boolean;
+{$ifdef SYSTEMDEBUG}
+      opennames : array [0..max_files-1] of pchar;
+   const
+      free_closed_names : boolean = true;
+{$endif SYSTEMDEBUG}
+
+{*****************************************************************************
+                         System Dependent Exit code
+*****************************************************************************}
+
+procedure ___exit(exitcode:longint);cdecl;external name '___exit';
+
+procedure do_close(handle : longint);forward;
+
+Procedure system_exit;
+var
+  h : byte;
+begin
+  for h:=0 to max_files-1 do
+    if openfiles[h] then
+      begin
+{$ifdef SYSTEMDEBUG}
+         writeln(stderr,'file ',opennames[h],' not closed at exit');
+{$endif SYSTEMDEBUG}
+         if h>=5 then
+           do_close(h);
+      end;
+  { halt is not always called !! }
+  { not on normal exit !! PM }
+{$ifndef EXCEPTIONS_IN_SYSTEM}
+  set_pm_interrupt($00,old_int00);
+  set_pm_interrupt($75,old_int75);
+{$endif EXCEPTIONS_IN_SYSTEM}
+  ___exit(exitcode);
+end;
+
+
+{$ifndef EXCEPTIONS_IN_SYSTEM}
+procedure new_int00;
+begin
+  HandleError(200);
+end;
+
+
+procedure new_int75;
+begin
+  asm
+        xorl    %eax,%eax
+        outb    %al,$0x0f0
+        movb    $0x20,%al
+        outb    %al,$0x0a0
+        outb    %al,$0x020
+  end;
+  HandleError(200);
+end;
+{$endif EXCEPTIONS_IN_SYSTEM}
+
+
+var
+  __stkbottom : longint;//###########external name '__stkbottom';
+
+procedure int_stackcheck(stack_size:longint);[public,alias:'FPC_STACKCHECK'];
+{
+  called when trying to get local stack if the compiler directive $S
+  is set this function must preserve esi !!!! because esi is set by
+  the calling proc for methods it must preserve all registers !!
+
+  With a 2048 byte safe area used to write to StdIo without crossing
+  the stack boundary
+}
+begin
+  asm
+        pushl   %eax
+        pushl   %ebx
+        movl    stack_size,%ebx
+        addl    $2048,%ebx
+        movl    %esp,%eax
+        subl    %ebx,%eax
+{$ifdef SYSTEMDEBUG}
+        movl    loweststack,%ebx
+        cmpl    %eax,%ebx
+        jb      .L_is_not_lowest
+        movl    %eax,loweststack
+.L_is_not_lowest:
+{$endif SYSTEMDEBUG}
+        movl    __stkbottom,%ebx
+        cmpl    %eax,%ebx
+        jae     .L__short_on_stack
+        popl    %ebx
+        popl    %eax
+        leave
+        ret     $4
+.L__short_on_stack:
+        { can be usefull for error recovery !! }
+        popl    %ebx
+        popl    %eax
+  end['EAX','EBX'];
+  HandleError(202);
+end;
+
+
+{*****************************************************************************
+                              ParamStr/Randomize
+*****************************************************************************}
+
+function paramcount : longint;
+begin
+  paramcount := argc - 1;
+end;
+
+
+function paramstr(l : longint) : string;
+begin
+  if (l>=0) and (l+1<=argc) then
+   paramstr:=strpas(argv[l])
+  else
+   paramstr:='';
+end;
+
+
+procedure randomize;
+var
+  hl   : longint;
+  regs : trealregs;
+begin
+  regs.realeax:=$2c00;
+  sysrealintr($21,regs);
+  hl:=lo(regs.realedx);
+  randseed:=hl*$10000+ lo(regs.realecx);
+end;
+
+{*****************************************************************************
+                              Heap Management
+*****************************************************************************}
+
+var int_heapsize:longint; external name 'HEAPSIZE';
+    int_heap:longint; external name 'HEAP';
+
+function getheapstart:pointer;
+begin
+  getheapstart:=@int_heap;
+end;
+
+
+function getheapsize:longint;
+begin
+  getheapsize:=int_heapsize;
+end;
+
+function ___sbrk(size:longint):longint;cdecl; external name '___sbrk';
+
+function Sbrk(size : longint):longint;assembler;
+asm
+{$ifdef SYSTEMDEBUG}
+        cmpb    $1,accept_sbrk
+        je      .Lsbrk
+        movl    $-1,%eax
+        jmp     .Lsbrk_fail
+      .Lsbrk:
+{$endif}
+        movl    size,%eax
+        pushl   %eax
+        call    ___sbrk
+        addl    $4,%esp
+{$ifdef SYSTEMDEBUG}
+      .Lsbrk_fail:
+{$endif}
+end;
+
+{ include standard heap management }
+{$include heap.inc}
+
+
+{****************************************************************************
+                        Low level File Routines
+ ****************************************************************************}
+
+procedure AllowSlash(p:pchar);
+var
+  i : longint;
+begin
+{ allow slash as backslash }
+  for i:=0 to strlen(p) do
+   if p[i]='/' then p[i]:='\';
+end;
+
+procedure do_close(handle : longint);
+var
+  regs : trealregs;
+begin
+  if Handle<=4 then
+   exit;
+  regs.realebx:=handle;
+  if handle<max_files then
+    begin
+       openfiles[handle]:=false;
+{$ifdef SYSTEMDEBUG}
+       if assigned(opennames[handle]) and free_closed_names then
+         begin
+            sysfreememsize(opennames[handle],strlen(opennames[handle])+1);
+            opennames[handle]:=nil;
+         end;
+{$endif SYSTEMDEBUG}
+    end;
+  regs.realeax:=$3e00;
+  sysrealintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   GetInOutRes(lo(regs.realeax));
+end;
+
+procedure do_erase(p : pchar);
+var
+  regs : trealregs;
+begin
+  AllowSlash(p);
+  syscopytodos(longint(p),strlen(p)+1);
+  regs.realedx:=tb_offset;
+  regs.realds:=tb_segment;
+{$ifndef RTLLITE}
+  if LFNSupport then
+   regs.realeax:=$7141
+  else
+{$endif RTLLITE}
+   regs.realeax:=$4100;
+  regs.realesi:=0;
+  regs.realecx:=0;
+  sysrealintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   GetInOutRes(lo(regs.realeax));
+end;
+
+procedure do_rename(p1,p2 : pchar);
+var
+  regs : trealregs;
+begin
+  AllowSlash(p1);
+  AllowSlash(p2);
+  if strlen(p1)+strlen(p2)+3>tb_size then
+   HandleError(217);
+  sysseg_move(get_ds,longint(p2),dos_selector,tb,strlen(p2)+1);
+  sysseg_move(get_ds,longint(p1),dos_selector,tb+strlen(p2)+2,strlen(p1)+1);
+  regs.realedi:=tb_offset;
+  regs.realedx:=tb_offset + strlen(p2)+2;
+  regs.realds:=tb_segment;
+  regs.reales:=tb_segment;
+{$ifndef RTLLITE}
+  if LFNSupport then
+   regs.realeax:=$7156
+  else
+{$endif RTLLITE}
+   regs.realeax:=$5600;
+  regs.realecx:=$ff;            { attribute problem here ! }
+  sysrealintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   GetInOutRes(lo(regs.realeax));
+end;
+
+function do_write(h,addr,len : longint) : longint;
+var
+  regs      : trealregs;
+  size,
+  writesize : longint;
+begin
+  writesize:=0;
+  while len > 0 do
+   begin
+     if len>tb_size then
+      size:=tb_size
+     else
+      size:=len;
+     syscopytodos(addr+writesize,size);
+     regs.realecx:=size;
+     regs.realedx:=tb_offset;
+     regs.realds:=tb_segment;
+     regs.realebx:=h;
+     regs.realeax:=$4000;
+     sysrealintr($21,regs);
+     if (regs.realflags and carryflag) <> 0 then
+      begin
+        GetInOutRes(lo(regs.realeax));
+        exit(writesize);
+      end;
+     inc(writesize,lo(regs.realeax));
+     dec(len,lo(regs.realeax));
+     { stop when not the specified size is written }
+     if lo(regs.realeax)<size then
+      break;
+   end;
+  Do_Write:=WriteSize;
+end;
+
+function do_read(h,addr,len : longint) : longint;
+var
+  regs     : trealregs;
+  size,
+  readsize : longint;
+begin
+  readsize:=0;
+  while len > 0 do
+   begin
+     if len>tb_size then
+      size:=tb_size
+     else
+      size:=len;
+     regs.realecx:=size;
+     regs.realedx:=tb_offset;
+     regs.realds:=tb_segment;
+     regs.realebx:=h;
+     regs.realeax:=$3f00;
+     sysrealintr($21,regs);
+     if (regs.realflags and carryflag) <> 0 then
+      begin
+        GetInOutRes(lo(regs.realeax));
+        do_read:=0;
+        exit;
+      end;
+     syscopyfromdos(addr+readsize,lo(regs.realeax));
+     inc(readsize,lo(regs.realeax));
+     dec(len,lo(regs.realeax));
+     { stop when not the specified size is read }
+     if lo(regs.realeax)<size then
+      break;
+   end;
+  do_read:=readsize;
+end;
+
+
+function do_filepos(handle : longint) : longint;
+var
+  regs : trealregs;
+begin
+  regs.realebx:=handle;
+  regs.realecx:=0;
+  regs.realedx:=0;
+  regs.realeax:=$4201;
+  sysrealintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   Begin
+     GetInOutRes(lo(regs.realeax));
+     do_filepos:=0;
+   end
+  else
+   do_filepos:=lo(regs.realedx) shl 16+lo(regs.realeax);
+end;
+
+
+procedure do_seek(handle,pos : longint);
+var
+  regs : trealregs;
+begin
+  regs.realebx:=handle;
+  regs.realecx:=pos shr 16;
+  regs.realedx:=pos and $ffff;
+  regs.realeax:=$4200;
+  sysrealintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   GetInOutRes(lo(regs.realeax));
+end;
+
+
+
+function do_seekend(handle:longint):longint;
+var
+  regs : trealregs;
+begin
+  regs.realebx:=handle;
+  regs.realecx:=0;
+  regs.realedx:=0;
+  regs.realeax:=$4202;
+  sysrealintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   Begin
+     GetInOutRes(lo(regs.realeax));
+     do_seekend:=0;
+   end
+  else
+   do_seekend:=lo(regs.realedx) shl 16+lo(regs.realeax);
+end;
+
+
+function do_filesize(handle : longint) : longint;
+var
+  aktfilepos : longint;
+begin
+  aktfilepos:=do_filepos(handle);
+  do_filesize:=do_seekend(handle);
+  do_seek(handle,aktfilepos);
+end;
+
+
+{ truncate at a given position }
+procedure do_truncate (handle,pos:longint);
+var
+  regs : trealregs;
+begin
+  do_seek(handle,pos);
+  regs.realecx:=0;
+  regs.realedx:=tb_offset;
+  regs.realds:=tb_segment;
+  regs.realebx:=handle;
+  regs.realeax:=$4000;
+  sysrealintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   GetInOutRes(lo(regs.realeax));
+end;
+
+{$ifndef RTLLITE}
+const
+  FileHandleCount : longint = 20;
+
+function Increase_file_handle_count : boolean;
+var
+  regs : trealregs;
+begin
+  Inc(FileHandleCount,10);
+  regs.realebx:=FileHandleCount;
+  regs.realeax:=$6700;
+  sysrealintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   begin
+    Increase_file_handle_count:=false;
+    Dec (FileHandleCount, 10);
+   end
+  else
+    Increase_file_handle_count:=true;
+end;
+{$endif not RTLLITE}
+
+procedure do_open(var f;p:pchar;flags:longint);
+{
+  filerec and textrec have both handle and mode as the first items so
+  they could use the same routine for opening/creating.
+  when (flags and $100)   the file will be append
+  when (flags and $1000)  the file will be truncate/rewritten
+  when (flags and $10000) there is no check for close (needed for textfiles)
+}
+var
+  regs   : trealregs;
+  action : longint;
+begin
+  AllowSlash(p);
+{ close first if opened }
+  if ((flags and $10000)=0) then
+   begin
+     case filerec(f).mode of
+      fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
+      fmclosed : ;
+     else
+      begin
+        inoutres:=102; {not assigned}
+        exit;
+      end;
+     end;
+   end;
+{ reset file handle }
+  filerec(f).handle:=UnusedHandle;
+  action:=$1;
+{ convert filemode to filerec modes }
+  case (flags and 3) of
+   0 : filerec(f).mode:=fminput;
+   1 : filerec(f).mode:=fmoutput;
+   2 : filerec(f).mode:=fminout;
+  end;
+  if (flags and $1000)<>0 then
+   action:=$12; {create file function}
+{ empty name is special }
+  if p[0]=#0 then
+   begin
+     case FileRec(f).mode of
+       fminput :
+         FileRec(f).Handle:=StdInputHandle;
+       fminout, { this is set by rewrite }
+       fmoutput :
+         FileRec(f).Handle:=StdOutputHandle;
+       fmappend :
+         begin
+           FileRec(f).Handle:=StdOutputHandle;
+           FileRec(f).mode:=fmoutput; {fool fmappend}
+         end;
+     end;
+     exit;
+   end;
+{ real dos call }
+  syscopytodos(longint(p),strlen(p)+1);
+{$ifndef RTLLITE}
+  if LFNSupport then
+   regs.realeax:=$716c
+  else
+{$endif RTLLITE}
+   regs.realeax:=$6c00;
+  regs.realedx:=action;
+  regs.realds:=tb_segment;
+  regs.realesi:=tb_offset;
+  regs.realebx:=$2000+(flags and $ff);
+  regs.realecx:=$20;
+  sysrealintr($21,regs);
+{$ifndef RTLLITE}
+  if (regs.realflags and carryflag) <> 0 then
+    if lo(regs.realeax)=4 then
+      if Increase_file_handle_count then
+        begin
+          { Try again }
+            if LFNSupport then
+             regs.realeax:=$716c
+            else
+             regs.realeax:=$6c00;
+          regs.realedx:=action;
+          regs.realds:=tb_segment;
+          regs.realesi:=tb_offset;
+          regs.realebx:=$2000+(flags and $ff);
+          regs.realecx:=$20;
+          sysrealintr($21,regs);
+        end;
+{$endif RTLLITE}
+  if (regs.realflags and carryflag) <> 0 then
+    begin
+      GetInOutRes(lo(regs.realeax));
+      exit;
+    end
+  else
+    begin
+      filerec(f).handle:=lo(regs.realeax);
+{$ifndef RTLLITE}
+      { for systems that have more then 20 by default ! }
+      if lo(regs.realeax)>FileHandleCount then
+        FileHandleCount:=lo(regs.realeax);
+{$endif RTLLITE}
+    end;
+  if lo(regs.realeax)<max_files then
+    begin
+{$ifdef SYSTEMDEBUG}
+       if openfiles[lo(regs.realeax)] and
+          assigned(opennames[lo(regs.realeax)]) then
+         begin
+            Writeln(stderr,'file ',opennames[lo(regs.realeax)],'(',lo(regs.realeax),') not closed but handle reused!');
+            sysfreememsize(opennames[lo(regs.realeax)],strlen(opennames[lo(regs.realeax)])+1);
+         end;
+{$endif SYSTEMDEBUG}
+       openfiles[lo(regs.realeax)]:=true;
+{$ifdef SYSTEMDEBUG}
+       opennames[lo(regs.realeax)] := sysgetmem(strlen(p)+1);
+       move(p^,opennames[lo(regs.realeax)]^,strlen(p)+1);
+{$endif SYSTEMDEBUG}
+    end;
+{ append mode }
+  if (flags and $100)<>0 then
+   begin
+     do_seekend(filerec(f).handle);
+     filerec(f).mode:=fmoutput; {fool fmappend}
+   end;
+end;
+
+function do_isdevice(handle:longint):boolean;
+var
+  regs : trealregs;
+begin
+  regs.realebx:=handle;
+  regs.realeax:=$4400;
+  sysrealintr($21,regs);
+  do_isdevice:=(regs.realedx and $80)<>0;
+  if (regs.realflags and carryflag) <> 0 then
+   GetInOutRes(lo(regs.realeax));
+end;
+
+{*****************************************************************************
+                           UnTyped File Handling
+*****************************************************************************}
+
+{$i file.inc}
+
+{*****************************************************************************
+                           Typed File Handling
+*****************************************************************************}
+
+{$i typefile.inc}
+
+{*****************************************************************************
+                           Text File Handling
+*****************************************************************************}
+
+{$DEFINE EOF_CTRLZ}
+
+{$i text.inc}
+
+
+{*****************************************************************************
+                           Generic Handling
+*****************************************************************************}
+
+{$ifdef TEST_GENERIC}
+{$i generic.inc}
+{$endif TEST_GENERIC}
+
+{*****************************************************************************
+                           Directory Handling
+*****************************************************************************}
+
+procedure DosDir(func:byte;const s:string);
+var
+  buffer : array[0..255] of char;
+  regs   : trealregs;
+begin
+  move(s[1],buffer,length(s));
+  buffer[length(s)]:=#0;
+  AllowSlash(pchar(@buffer));
+  { True DOS does not like backslashes at end
+    Win95 DOS accepts this !!
+    but "\" and "c:\" should still be kept and accepted hopefully PM }
+  if (length(s)>0) and (buffer[length(s)-1]='\') and
+     Not ((length(s)=1) or ((length(s)=3) and (s[2]=':'))) then
+    buffer[length(s)-1]:=#0;
+  syscopytodos(longint(@buffer),length(s)+1);
+  regs.realedx:=tb_offset;
+  regs.realds:=tb_segment;
+{$ifndef RTLLITE}
+  if LFNSupport then
+   regs.realeax:=$7100+func
+  else
+{$endif RTLLITE}
+   regs.realeax:=func shl 8;
+  sysrealintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   GetInOutRes(lo(regs.realeax));
+end;
+
+
+procedure mkdir(const s : string);[IOCheck];
+begin
+  If (s='') or (InOutRes <> 0) then
+   exit;
+  DosDir($39,s);
+end;
+
+
+procedure rmdir(const s : string);[IOCheck];
+begin
+  if (s = '.' ) then
+    InOutRes := 16;
+  If (s='') or (InOutRes <> 0) then
+   exit;
+  DosDir($3a,s);
+end;
+
+
+procedure chdir(const s : string);[IOCheck];
+var
+  regs : trealregs;
+begin
+  If (s='') or (InOutRes <> 0) then
+   exit;
+{ First handle Drive changes }
+  if (length(s)>=2) and (s[2]=':') then
+   begin
+     regs.realedx:=(ord(s[1]) and (not 32))-ord('A');
+     regs.realeax:=$0e00;
+     sysrealintr($21,regs);
+     regs.realeax:=$1900;
+     sysrealintr($21,regs);
+     if byte(regs.realeax)<>byte(regs.realedx) then
+      begin
+        Inoutres:=15;
+        exit;
+      end;
+     { DosDir($3b,'c:') give Path not found error on
+       pure DOS PM }
+     if length(s)=2 then
+       exit;
+   end;
+{ do the normal dos chdir }
+  DosDir($3b,s);
+end;
+
+
+procedure getdir(drivenr : byte;var dir : shortstring);
+var
+  temp : array[0..255] of char;
+  i    : longint;
+  regs : trealregs;
+begin
+  regs.realedx:=drivenr;
+  regs.realesi:=tb_offset;
+  regs.realds:=tb_segment;
+{$ifndef RTLLITE}
+  if LFNSupport then
+   regs.realeax:=$7147
+  else
+{$endif RTLLITE}
+   regs.realeax:=$4700;
+  sysrealintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   Begin
+     GetInOutRes(lo(regs.realeax));
+     Dir := char (DriveNr + 64) + ':\';
+     exit;
+   end
+  else
+   syscopyfromdos(longint(@temp),251);
+{ conversion to Pascal string including slash conversion }
+  i:=0;
+  while (temp[i]<>#0) do
+   begin
+     if temp[i]='/' then
+      temp[i]:='\';
+     dir[i+4]:=temp[i];
+     inc(i);
+   end;
+  dir[2]:=':';
+  dir[3]:='\';
+  dir[0]:=char(i+3);
+{ upcase the string }
+  if not FileNameCaseSensitive then
+   dir:=upcase(dir);
+  if drivenr<>0 then   { Drive was supplied. We know it }
+   dir[1]:=char(65+drivenr-1)
+  else
+   begin
+   { We need to get the current drive from DOS function 19H  }
+   { because the drive was the default, which can be unknown }
+     regs.realeax:=$1900;
+     sysrealintr($21,regs);
+     i:= (regs.realeax and $ff) + ord('A');
+     dir[1]:=chr(i);
+   end;
+end;
+
+{*****************************************************************************
+                         SystemUnit Initialization
+*****************************************************************************}
+
+{$ifndef RTLLITE}
+function CheckLFN:boolean;
+var
+  regs     : TRealRegs;
+  RootName : pchar;
+begin
+{ Check LFN API on drive c:\ }
+  RootName:='C:\';
+  syscopytodos(longint(RootName),strlen(RootName)+1);
+{ Call 'Get Volume Information' ($71A0) }
+  regs.realeax:=$71a0;
+  regs.reales:=tb_segment;
+  regs.realedi:=tb_offset;
+  regs.realecx:=32;
+  regs.realds:=tb_segment;
+  regs.realedx:=tb_offset;
+  regs.realflags:=carryflag;
+  sysrealintr($21,regs);
+{ If carryflag=0 and LFN API bit in ebx is set then use Long file names }
+  CheckLFN:=(regs.realflags and carryflag=0) and (regs.realebx and $4000=$4000);
+end;
+{$endif RTLLITE}
+
+{$ifdef MT}
+{$I thread.inc}
+{$endif MT}
+
+{$ifndef RTLLITE}
+{$ifdef  EXCEPTIONS_IN_SYSTEM}
+{$define IN_SYSTEM}
+{$i dpmiexcp.pp}
+{$endif  EXCEPTIONS_IN_SYSTEM}
+{$endif RTLLITE}
+
+var
+  temp_int : tseginfo;
+Begin
+  alloc_tb;
+{$ifndef EXCEPTIONS_IN_SYSTEM}
+{ save old int 0 and 75 }
+  get_pm_interrupt($00,old_int00);
+  get_pm_interrupt($75,old_int75);
+  temp_int.segment:=get_cs;
+  temp_int.offset:=@new_int00;
+  set_pm_interrupt($00,temp_int);
+  temp_int.offset:=@new_int75;
+  set_pm_interrupt($75,temp_int);
+{$endif EXCEPTIONS_IN_SYSTEM}
+{$IFDEF SYSTEMDEBUG}
+{ to test stack depth }
+  loweststack:=maxlongint;
+{$ENDIF}
+{ Setup heap }
+  InitHeap;
+{$ifdef MT}
+  { before this, you can't use thread vars !!!! }
+  { threadvarblocksize is calculate before the initialization }
+  { of the system unit                                        }
+  mainprogramthreadblock :=  sysgetmem(threadvarblocksize);
+{$endif MT}
+  InitExceptions;
+{ Setup stdin, stdout and stderr }
+  OpenStdIO(Input,fmInput,StdInputHandle);
+  OpenStdIO(Output,fmOutput,StdOutputHandle);
+  OpenStdIO(StdOut,fmOutput,StdOutputHandle);
+  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
+{ Setup environment and arguments }
+  Setup_Environment;
+  Setup_Arguments;
+{ Use LFNSupport LFN }
+  LFNSupport:=CheckLFN;
+  if LFNSupport then
+   FileNameCaseSensitive:=true;
+{ Reset IO Error }
+  InOutRes:=0;
+{$ifndef RTLLITE}
+{$ifdef  EXCEPTIONS_IN_SYSTEM}
+  InitDPMIExcp;
+  InstallDefaultHandlers;
+{$endif  EXCEPTIONS_IN_SYSTEM}
+{$endif RTLLITE}
+End.
+
+END.

rtl/watcom/watcom.pp

@@ -0,0 +1,1058 @@
+
+//  this is generally go32 unit from go32v2 target.
+//  maybe these units should be merged into one ( uses dpmi ? )
+
+//  not yet finished
+
+unit watcom;
+
+{$S-,R-,I-,Q-} {no stack check, used by DPMIEXCP !! }
+
+interface
+
+    const
+    { contants for the run modes returned by get_run_mode }
+       rm_unknown = 0;
+       rm_raw     = 1;     { raw (without HIMEM) }
+       rm_xms     = 2;     { XMS (for example with HIMEM, without EMM386) }
+       rm_vcpi    = 3;     { VCPI (for example HIMEM and EMM386) }
+       rm_dpmi    = 4;     { DPMI (for example DOS box or 386Max) }
+
+    { flags }
+       carryflag     = $001;
+       parityflag    = $004;
+       auxcarryflag  = $010;
+       zeroflag      = $040;
+       signflag      = $080;
+       trapflag      = $100;
+       interruptflag = $200;
+       directionflag = $400;
+       overflowflag  = $800;
+
+    type
+       tmeminfo = record
+          available_memory,
+          available_pages,
+          available_lockable_pages,
+          linear_space,
+          unlocked_pages,
+          available_physical_pages,
+          total_physical_pages,
+          free_linear_space,
+          max_pages_in_paging_file,
+          reserved0,
+          reserved1,
+          reserved2 : longint;
+       end;
+
+       tseginfo = record
+          offset  : pointer;
+          segment : word;
+       end;
+
+       trealregs = record
+         case integer of
+          1: { 32-bit } (EDI, ESI, EBP, Res, EBX, EDX, ECX, EAX: longint;
+                         Flags, ES, DS, FS, GS, IP, CS, SP, SS: word);
+          2: { 16-bit } (DI, DI2, SI, SI2, BP, BP2, R1, R2: word;
+                         BX, BX2, DX, DX2, CX, CX2, AX, AX2: word);
+          3: { 8-bit }  (stuff: array[1..4] of longint;
+                         BL, BH, BL2, BH2, DL, DH, DL2, DH2,
+                         CL, CH, CL2, CH2, AL, AH, AL2, AH2: byte);
+          4: { Compat } (RealEDI, RealESI, RealEBP, RealRES,
+                         RealEBX, RealEDX, RealECX, RealEAX: longint;
+                         RealFlags,
+                         RealES, RealDS, RealFS, RealGS,
+                         RealIP, RealCS, RealSP, RealSS: word);
+       end;
+
+      registers = trealregs;
+
+    { this works only with real DPMI }
+    function allocate_ldt_descriptors(count : word) : word;
+    function free_ldt_descriptor(d : word) : boolean;
+    function segment_to_descriptor(seg : word) : word;
+    function get_next_selector_increment_value : word;
+    function get_segment_base_address(d : word) : longint;
+    function set_segment_base_address(d : word;s : longint) : boolean;
+    function set_segment_limit(d : word;s : longint) : boolean;
+    function set_descriptor_access_right(d : word;w : word) : longint;
+    function create_code_segment_alias_descriptor(seg : word) : word;
+    function get_linear_addr(phys_addr : longint;size : longint) : longint;
+    function get_segment_limit(d : word) : longint;
+    function get_descriptor_access_right(d : word) : longint;
+    function get_page_size:longint;
+    function map_device_in_memory_block(handle,offset,pagecount,device:longint):boolean;
+    function realintr(intnr : word;var regs : trealregs) : boolean;
+
+    { is needed for functions which need a real mode buffer }
+    function global_dos_alloc(bytes : longint) : longint;
+    function global_dos_free(selector : word) : boolean;
+
+    var
+       { selector for the DOS memory (only usable if in DPMI mode) }
+       dosmemselector : word;
+       { result of dpmi call }
+       int31error : word;
+
+    { this procedure copies data where the source and destination }
+    { are specified by 48 bit pointers                            }
+    { Note: the procedure checks only for overlapping if          }
+    { source selector=destination selector                        }
+    procedure seg_move(sseg : word;source : longint;dseg : word;dest : longint;count : longint);
+
+    { fills a memory area specified by a 48 bit pointer with c }
+    procedure seg_fillchar(seg : word;ofs : longint;count : longint;c : char);
+    procedure seg_fillword(seg : word;ofs : longint;count : longint;w : word);
+
+    {************************************}
+    { this works with all PM interfaces: }
+    {************************************}
+
+    function get_meminfo(var meminfo : tmeminfo) : boolean;
+    function get_pm_interrupt(vector : byte;var intaddr : tseginfo) : boolean;
+    function set_pm_interrupt(vector : byte;const intaddr : tseginfo) : boolean;
+    function get_rm_interrupt(vector : byte;var intaddr : tseginfo) : boolean;
+    function set_rm_interrupt(vector : byte;const intaddr : tseginfo) : boolean;
+    function get_exception_handler(e : byte;var intaddr : tseginfo) : boolean;
+    function set_exception_handler(e : byte;const intaddr : tseginfo) : boolean;
+    function get_pm_exception_handler(e : byte;var intaddr : tseginfo) : boolean;
+    function set_pm_exception_handler(e : byte;const intaddr : tseginfo) : boolean;
+    function free_rm_callback(var intaddr : tseginfo) : boolean;
+    function get_rm_callback(pm_func : pointer;const reg : trealregs;var rmcb : tseginfo) : boolean;
+    function get_cs : word;
+    function get_ds : word;
+    function get_ss : word;
+
+    { locking functions }
+    function allocate_memory_block(size:longint):longint;
+    function free_memory_block(blockhandle : longint) : boolean;
+    function request_linear_region(linearaddr, size : longint;
+                                   var blockhandle : longint) : boolean;
+    function lock_linear_region(linearaddr, size : longint) : boolean;
+    function lock_data(var data;size : longint) : boolean;
+    function lock_code(functionaddr : pointer;size : longint) : boolean;
+    function unlock_linear_region(linearaddr, size : longint) : boolean;
+    function unlock_data(var data;size : longint) : boolean;
+    function unlock_code(functionaddr : pointer;size : longint) : boolean;
+
+    { disables and enables interrupts }
+    procedure disable;
+    procedure enable;
+
+    function inportb(port : word) : byte;
+    function inportw(port : word) : word;
+    function inportl(port : word) : longint;
+
+    procedure outportb(port : word;data : byte);
+    procedure outportw(port : word;data : word);
+    procedure outportl(port : word;data : longint);
+    function get_run_mode : word;
+
+    procedure copytodos(var addr; len : longint);
+    procedure copyfromdos(var addr; len : longint);
+
+    procedure dpmi_dosmemput(seg : word;ofs : word;var data;count : longint);
+    procedure dpmi_dosmemget(seg : word;ofs : word;var data;count : longint);
+    procedure dpmi_dosmemmove(sseg,sofs,dseg,dofs : word;count : longint);
+    procedure dpmi_dosmemfillchar(seg,ofs : word;count : longint;c : char);
+    procedure dpmi_dosmemfillword(seg,ofs : word;count : longint;w : word);
+
+
+
+    const
+       { this procedures are assigned to the procedure which are needed }
+       { for the current mode to access DOS memory                      }
+       { It's strongly recommended to use this procedures!              }
+       dosmemput      : procedure(seg : word;ofs : word;var data;count : longint)=@dpmi_dosmemput;
+       dosmemget      : procedure(seg : word;ofs : word;var data;count : longint)=@dpmi_dosmemget;
+       dosmemmove     : procedure(sseg,sofs,dseg,dofs : word;count : longint)=@dpmi_dosmemmove;
+       dosmemfillchar : procedure(seg,ofs : word;count : longint;c : char)=@dpmi_dosmemfillchar;
+       dosmemfillword : procedure(seg,ofs : word;count : longint;w : word)=@dpmi_dosmemfillword;
+
+  implementation
+
+{$asmmode ATT}
+
+
+    { the following procedures copy from and to DOS memory using DPMI }
+    procedure dpmi_dosmemput(seg : word;ofs : word;var data;count : longint);
+
+      begin
+         seg_move(get_ds,longint(@data),dosmemselector,seg*16+ofs,count);
+      end;
+
+    procedure dpmi_dosmemget(seg : word;ofs : word;var data;count : longint);
+
+      begin
+         seg_move(dosmemselector,seg*16+ofs,get_ds,longint(@data),count);
+      end;
+
+    procedure dpmi_dosmemmove(sseg,sofs,dseg,dofs : word;count : longint);
+
+      begin
+         seg_move(dosmemselector,sseg*16+sofs,dosmemselector,dseg*16+dofs,count);
+      end;
+
+    procedure dpmi_dosmemfillchar(seg,ofs : word;count : longint;c : char);
+
+      begin
+         seg_fillchar(dosmemselector,seg*16+ofs,count,c);
+      end;
+
+    procedure dpmi_dosmemfillword(seg,ofs : word;count : longint;w : word);
+
+      begin
+         seg_fillword(dosmemselector,seg*16+ofs,count,w);
+      end;
+
+
+    procedure test_int31(flag : longint);
+      begin
+         asm
+            pushl %ebx
+            movw  $0,INT31ERROR
+            movl  flag,%ebx
+            testb $1,%bl
+            jz    .Lti31_1
+            movw  %ax,INT31ERROR
+            xorl  %eax,%eax
+            jmp   .Lti31_2
+            .Lti31_1:
+            movl  $1,%eax
+            .Lti31_2:
+            popl  %ebx
+         end;
+      end;
+
+    function global_dos_alloc(bytes : longint) : longint;
+
+      begin
+         asm
+            movl bytes,%ebx
+            addl $0xf,%ebx              // round up
+            shrl $0x4,%ebx              // convert to Paragraphs
+            movl $0x100,%eax            // function 0x100
+            int  $0x31
+            jnc  .LDos_OK
+            movw %ax,INT31ERROR
+            xorl %eax,%eax
+            jmp  .LDos_end
+          .LDos_OK:
+            shll $0x10,%eax             // return Segment in hi(Result)
+            movw %dx,%ax                // return Selector in lo(Result)
+          .LDos_end:
+            movl %eax,__result
+         end;
+      end;
+
+    function  global_dos_free(selector : word) : boolean;
+
+      begin
+         asm
+            movw Selector,%dx
+            movl $0x101,%eax
+            int  $0x31
+            setnc %al
+            movb %al,__RESULT
+         end;
+      end;
+
+    function realintr(intnr : word;var regs : trealregs) : boolean;
+
+      begin
+         regs.realsp:=0;
+         regs.realss:=0;
+         asm
+            { save all used registers to avoid crash under NTVDM }
+            { when spawning a 32-bit DPMI application            }
+            pushw %fs
+            movw  intnr,%bx
+            xorl  %ecx,%ecx
+            movl  regs,%edi
+            { es is always equal ds }
+            movl  $0x300,%eax
+            int   $0x31
+            popw  %fs
+            setnc %al
+            movb  %al,__RESULT
+         end;
+      end;
+
+    procedure seg_fillchar(seg : word;ofs : longint;count : longint;c : char);
+
+      begin
+         asm
+            movl ofs,%edi
+            movl count,%ecx
+            movb c,%dl
+            { load es with selector }
+            pushw %es
+            movw seg,%ax
+            movw %ax,%es
+            { fill eax with duplicated c }
+            { so we can use stosl        }
+            movb %dl,%dh
+            movw %dx,%ax
+            shll $16,%eax
+            movw %dx,%ax
+            movl %ecx,%edx
+            shrl $2,%ecx
+            cld
+            rep
+            stosl
+            movl %edx,%ecx
+            andl $3,%ecx
+            rep
+            stosb
+            popw %es
+         end ['EAX','ECX','EDX','EDI'];
+      end;
+
+    procedure seg_fillword(seg : word;ofs : longint;count : longint;w : word);
+
+      begin
+         asm
+            movl ofs,%edi
+            movl count,%ecx
+            movw w,%dx
+            { load segment }
+            pushw %es
+            movw seg,%ax
+            movw %ax,%es
+            { fill eax }
+            movw %dx,%ax
+            shll $16,%eax
+            movw %dx,%ax
+            movl %ecx,%edx
+            shrl $1,%ecx
+            cld
+            rep
+            stosl
+            movl %edx,%ecx
+            andl $1,%ecx
+            rep
+            stosw
+            popw %es
+         end ['EAX','ECX','EDX','EDI'];
+      end;
+
+    procedure seg_move(sseg : word;source : longint;dseg : word;dest : longint;count : longint);
+
+      begin
+         if count=0 then
+           exit;
+         if (sseg<>dseg) or ((sseg=dseg) and (source>dest)) then
+           asm
+              pushw %es
+              pushw %ds
+              cld
+              movl count,%ecx
+              movl source,%esi
+              movl dest,%edi
+              movw dseg,%ax
+              movw %ax,%es
+              movw sseg,%ax
+              movw %ax,%ds
+              movl %ecx,%eax
+              shrl $2,%ecx
+              rep
+              movsl
+              movl %eax,%ecx
+              andl $3,%ecx
+              rep
+              movsb
+              popw %ds
+              popw %es
+           end ['ESI','EDI','ECX','EAX']
+         else if (source<dest) then
+           { copy backward for overlapping }
+           asm
+              pushw %es
+              pushw %ds
+              std
+              movl count,%ecx
+              movl source,%esi
+              movl dest,%edi
+              movw dseg,%ax
+              movw %ax,%es
+              movw sseg,%ax
+              movw %ax,%ds
+              addl %ecx,%esi
+              addl %ecx,%edi
+              movl %ecx,%eax
+              andl $3,%ecx
+              orl %ecx,%ecx
+              jz .LSEG_MOVE1
+
+              { calculate esi and edi}
+              decl %esi
+              decl %edi
+              rep
+              movsb
+              incl %esi
+              incl %edi
+           .LSEG_MOVE1:
+              subl $4,%esi
+              subl $4,%edi
+              movl %eax,%ecx
+              shrl $2,%ecx
+              rep
+              movsl
+              cld
+              popw %ds
+              popw %es
+           end ['ESI','EDI','ECX'];
+      end;
+
+    procedure outportb(port : word;data : byte);
+
+      begin
+         asm
+            movw port,%dx
+            movb data,%al
+            outb %al,%dx
+         end ['EAX','EDX'];
+      end;
+
+    procedure outportw(port : word;data : word);
+
+      begin
+         asm
+            movw port,%dx
+            movw data,%ax
+            outw %ax,%dx
+         end ['EAX','EDX'];
+      end;
+
+    procedure outportl(port : word;data : longint);
+
+      begin
+         asm
+            movw port,%dx
+            movl data,%eax
+            outl %eax,%dx
+         end ['EAX','EDX'];
+      end;
+
+    function inportb(port : word) : byte;
+
+      begin
+         asm
+            movw port,%dx
+            inb %dx,%al
+            movb %al,__RESULT
+         end ['EAX','EDX'];
+      end;
+
+    function inportw(port : word) : word;
+
+      begin
+         asm
+            movw port,%dx
+            inw %dx,%ax
+            movw %ax,__RESULT
+         end ['EAX','EDX'];
+      end;
+
+    function inportl(port : word) : longint;
+
+      begin
+         asm
+            movw port,%dx
+            inl %dx,%eax
+            movl %eax,__RESULT
+         end ['EAX','EDX'];
+      end;
+
+
+
+    function get_cs : word;assembler;
+      asm
+            movw %cs,%ax
+      end;
+
+
+    function get_ss : word;assembler;
+      asm
+            movw %ss,%ax
+      end;
+
+
+    function get_ds : word;assembler;
+      asm
+            movw %ds,%ax
+      end;
+
+
+    function set_pm_interrupt(vector : byte;const intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movl intaddr,%eax
+            movl (%eax),%edx
+            movw 4(%eax),%cx
+            movl $0x205,%eax
+            movb vector,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function set_rm_interrupt(vector : byte;const intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movl intaddr,%eax
+            movw (%eax),%dx
+            movw 4(%eax),%cx
+            movl $0x201,%eax
+            movb vector,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function set_pm_exception_handler(e : byte;const intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movl intaddr,%eax
+            movl (%eax),%edx
+            movw 4(%eax),%cx
+            movl $0x212,%eax
+            movb e,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function set_exception_handler(e : byte;const intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movl intaddr,%eax
+            movl (%eax),%edx
+            movw 4(%eax),%cx
+            movl $0x203,%eax
+            movb e,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function get_pm_exception_handler(e : byte;var intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movl $0x210,%eax
+            movb e,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl intaddr,%eax
+            movl %edx,(%eax)
+            movw %cx,4(%eax)
+         end;
+      end;
+
+    function get_exception_handler(e : byte;var intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movl $0x202,%eax
+            movb e,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl intaddr,%eax
+            movl %edx,(%eax)
+            movw %cx,4(%eax)
+         end;
+      end;
+
+    function get_pm_interrupt(vector : byte;var intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movb vector,%bl
+            movl $0x204,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl intaddr,%eax
+            movl %edx,(%eax)
+            movw %cx,4(%eax)
+         end;
+      end;
+
+    function get_rm_interrupt(vector : byte;var intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movb vector,%bl
+            movl $0x200,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl intaddr,%eax
+            movzwl %dx,%edx
+            movl %edx,(%eax)
+            movw %cx,4(%eax)
+         end;
+      end;
+
+    function free_rm_callback(var intaddr : tseginfo) : boolean;
+      begin
+         asm
+            movl intaddr,%eax
+            movw (%eax),%dx
+            movw 4(%eax),%cx
+            movl $0x304,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    { here we must use ___v2prt0_ds_alias instead of from v2prt0.s
+    because the exception processor sets the ds limit to $fff
+    at hardware exceptions }
+
+//!!!!    var
+//!!!!       ___v2prt0_ds_alias : word; external name '___v2prt0_ds_alias';
+   var ___v2prt0_ds_alias : word; 
+
+    function get_rm_callback(pm_func : pointer;const reg : trealregs;var rmcb : tseginfo) : boolean;
+      begin
+         asm
+            movl  pm_func,%esi
+            movl  reg,%edi
+            pushw %es
+            movw  ___v2prt0_ds_alias,%ax
+            movw  %ax,%es
+            pushw %ds
+            movw  %cs,%ax
+            movw  %ax,%ds
+            movl  $0x303,%eax
+            int   $0x31
+            popw  %ds
+            popw  %es
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl  rmcb,%eax
+            movzwl %dx,%edx
+            movl  %edx,(%eax)
+            movw  %cx,4(%eax)
+         end;
+      end;
+
+    function allocate_ldt_descriptors(count : word) : word;
+
+      begin
+         asm
+            movw count,%cx
+            xorl %eax,%eax
+            int $0x31
+            movw %ax,__RESULT
+         end;
+      end;
+
+    function free_ldt_descriptor(d : word) : boolean;
+
+      begin
+         asm
+            movw d,%bx
+            movl $1,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function segment_to_descriptor(seg : word) : word;
+
+      begin
+         asm
+            movw seg,%bx
+            movl $2,%eax
+            int $0x31
+            movw %ax,__RESULT
+         end;
+      end;
+
+    function get_next_selector_increment_value : word;
+
+      begin
+         asm
+            movl $3,%eax
+            int $0x31
+            movw %ax,__RESULT
+         end;
+      end;
+
+    function get_segment_base_address(d : word) : longint;
+
+      begin
+         asm
+            movw d,%bx
+            movl $6,%eax
+            int $0x31
+            xorl %eax,%eax
+            movw %dx,%ax
+            shll $16,%ecx
+            orl %ecx,%eax
+            movl %eax,__RESULT
+         end;
+      end;
+
+    function get_page_size:longint;
+      begin
+        asm
+           movl $0x604,%eax
+           int $0x31
+           shll $16,%ebx
+           movw %cx,%bx
+           movl %ebx,__RESULT
+        end;
+      end;
+
+    function request_linear_region(linearaddr, size : longint;
+                                   var blockhandle : longint) : boolean;
+      var
+         pageofs : longint;
+
+      begin
+         pageofs:=linearaddr and $3ff;
+         linearaddr:=linearaddr-pageofs;
+         size:=size+pageofs;
+         asm
+            movl $0x504,%eax
+            movl linearaddr,%ebx
+            movl size,%ecx
+            movl $1,%edx
+            xorl %esi,%esi
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl blockhandle,%eax
+            movl %esi,(%eax)
+            movl %ebx,pageofs
+         end;
+         if pageofs<>linearaddr then
+           request_linear_region:=false;
+      end;
+
+    function allocate_memory_block(size:longint):longint;
+      begin
+        asm
+          movl  $0x501,%eax
+          movl  size,%ecx
+          movl  %ecx,%ebx
+          shrl  $16,%ebx
+          andl  $65535,%ecx
+          int   $0x31
+          jnc   .Lallocate_mem_block_err
+          xorl  %ebx,%ebx
+          xorl  %ecx,%ecx
+       .Lallocate_mem_block_err:
+          shll  $16,%ebx
+          movw  %cx,%bx
+          shll  $16,%esi
+          movw  %di,%si
+          movl  %ebx,__RESULT
+        end;
+     end;
+
+    function free_memory_block(blockhandle : longint) : boolean;
+      begin
+         asm
+            movl blockhandle,%esi
+            movl %esi,%edi
+            shll $16,%esi
+            movl $0x502,%eax
+            int  $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function lock_linear_region(linearaddr, size : longint) : boolean;
+
+      begin
+          asm
+            movl  $0x600,%eax
+            movl  linearaddr,%ecx
+            movl  %ecx,%ebx
+            shrl  $16,%ebx
+            movl  size,%esi
+            movl  %esi,%edi
+            shrl  $16,%esi
+            int   $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+          end;
+      end;
+
+    function lock_data(var data;size : longint) : boolean;
+
+      var
+         linearaddr : longint;
+
+      begin
+         if get_run_mode<>rm_dpmi then
+           exit;
+         linearaddr:=longint(@data)+get_segment_base_address(get_ds);
+         lock_data:=lock_linear_region(linearaddr,size);
+      end;
+
+    function lock_code(functionaddr : pointer;size : longint) : boolean;
+
+      var
+         linearaddr : longint;
+
+      begin
+         if get_run_mode<>rm_dpmi then
+           exit;
+         linearaddr:=longint(functionaddr)+get_segment_base_address(get_cs);
+         lock_code:=lock_linear_region(linearaddr,size);
+      end;
+
+    function unlock_linear_region(linearaddr,size : longint) : boolean;
+
+      begin
+         asm
+            movl  $0x601,%eax
+            movl  linearaddr,%ecx
+            movl  %ecx,%ebx
+            shrl  $16,%ebx
+            movl  size,%esi
+            movl  %esi,%edi
+            shrl  $16,%esi
+            int   $0x31
+            pushf
+            call  test_int31
+            movb  %al,__RESULT
+         end;
+      end;
+
+    function unlock_data(var data;size : longint) : boolean;
+
+      var
+         linearaddr : longint;
+      begin
+         if get_run_mode<>rm_dpmi then
+           exit;
+         linearaddr:=longint(@data)+get_segment_base_address(get_ds);
+         unlock_data:=unlock_linear_region(linearaddr,size);
+      end;
+
+    function unlock_code(functionaddr : pointer;size : longint) : boolean;
+
+      var
+         linearaddr : longint;
+      begin
+         if get_run_mode<>rm_dpmi then
+           exit;
+         linearaddr:=longint(functionaddr)+get_segment_base_address(get_cs);
+         unlock_code:=unlock_linear_region(linearaddr,size);
+      end;
+
+    function set_segment_base_address(d : word;s : longint) : boolean;
+
+      begin
+         asm
+            movw d,%bx
+            leal s,%eax
+            movw (%eax),%dx
+            movw 2(%eax),%cx
+            movl $7,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function set_descriptor_access_right(d : word;w : word) : longint;
+
+      begin
+         asm
+            movw d,%bx
+            movw w,%cx
+            movl $9,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movw %ax,__RESULT
+         end;
+      end;
+
+    function set_segment_limit(d : word;s : longint) : boolean;
+
+      begin
+         asm
+            movw d,%bx
+            leal s,%eax
+            movw (%eax),%dx
+            movw 2(%eax),%cx
+            movl $8,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function get_descriptor_access_right(d : word) : longint;
+
+      begin
+         asm
+            movzwl d,%eax
+            lar %eax,%eax
+            jz .L_ok
+            xorl %eax,%eax
+         .L_ok:
+            movl %eax,__RESULT
+         end;
+      end;
+    function get_segment_limit(d : word) : longint;
+
+      begin
+         asm
+            movzwl d,%eax
+            lsl %eax,%eax
+            jz .L_ok2
+            xorl %eax,%eax
+         .L_ok2:
+            movl %eax,__RESULT
+         end;
+      end;
+
+    function create_code_segment_alias_descriptor(seg : word) : word;
+
+      begin
+         asm
+            movw seg,%bx
+            movl $0xa,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movw %ax,__RESULT
+         end;
+      end;
+
+    function get_meminfo(var meminfo : tmeminfo) : boolean;
+
+      begin
+         asm
+            movl meminfo,%edi
+            movl $0x500,%eax
+            int $0x31
+            pushf
+            movb %al,__RESULT
+            call test_int31
+         end;
+      end;
+
+    function get_linear_addr(phys_addr : longint;size : longint) : longint;
+
+      begin
+         asm
+            movl phys_addr,%ebx
+            movl %ebx,%ecx
+            shrl $16,%ebx
+            movl size,%esi
+            movl %esi,%edi
+            shrl $16,%esi
+            movl $0x800,%eax
+            int $0x31
+            pushf
+            call test_int31
+            shll $16,%ebx
+            movw %cx,%bx
+            movl %ebx,__RESULT
+         end;
+      end;
+
+    procedure disable;assembler;
+
+      asm
+         cli
+      end;
+
+    procedure enable;assembler;
+
+      asm
+         sti
+      end;
+
+
+//    var
+//      _run_mode : word;external name '_run_mode';
+
+    function get_run_mode : word;
+
+      begin
+//         get_run_mode:=_run_mode; !!!!!!!!!!
+         get_run_mode:=rm_unknown;
+      end;
+
+    function map_device_in_memory_block(handle,offset,pagecount,device:longint):boolean;
+      begin
+         asm
+           movl device,%edx
+           movl handle,%esi
+           movl offset,%ebx
+           movl pagecount,%ecx
+           movl $0x0508,%eax
+           int $0x31
+           pushf
+           setnc %al
+           movb %al,__RESULT
+           call test_int31
+         end;
+      end;
+
+{*****************************************************************************
+                              Transfer Buffer
+*****************************************************************************}
+
+    procedure copytodos(var addr; len : longint);
+       begin
+          if len>tb_size then
+            runerror(217);
+          seg_move(get_ds,longint(@addr),dosmemselector,transfer_buffer,len);
+       end;
+
+
+    procedure copyfromdos(var addr; len : longint);
+       begin
+          if len>tb_size then
+            runerror(217);
+          seg_move(dosmemselector,transfer_buffer,get_ds,longint(@addr),len);
+       end;
+
+
+begin
+   int31error:=0;
+   dosmemselector:=get_ds;
+end.