freepascal.compiler/rtl/dos/crt.pp

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1993-98 by the Free Pascal development team.

    Borland Pascal 7 Compatible CRT Unit for Go32V1 and Go32V2

    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 crt;
interface

{$I os.inc}

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
  go32;

{$ifdef VER0_99_5}
  {$I386_DIRECT} {due to a bug in the assembler reader using a  }
                 { call to a symbol will crash under FPC 0.99.5 }
{$endif}

{$ASMMODE ATT}

var
  DelayCnt,  { don't modify this var name, as it is hard coded }
  ScreenWidth,
  ScreenHeight : longint;


{
  definition of textrec is in textrec.inc
}
{$i textrec.inc}


{****************************************************************************
                           Low level Routines
****************************************************************************}

procedure setscreenmode(mode : byte);
{$ifdef GO32V2}
var
  regs : trealregs;
{$endif GO32V2}
begin
{$ifdef GO32V2}
  regs.realeax:=mode;
  realintr($10,regs);
{$else GO32V2}
  asm
        movb    8(%ebp),%al
        xorb    %ah,%ah
        pushl   %ebp
        int     $0x10
        popl    %ebp
  end;
{$endif GO32V2}
end;


function GetScreenHeight : longint;
begin
{$ifdef GO32V2}
  getscreenheight:=mem[$40:$84]+1;
{$else}
  dosmemget($40,$84,getscreenheight,1);
  inc(getscreenheight);
{$endif}
end;


function GetScreenWidth : longint;
begin
{$ifdef GO32V2}
  getscreenwidth:=mem[$40:$4a];
{$else}
  dosmemget($40,$4a,getscreenwidth,1);
{$endif}
end;


procedure SetScreenCursor(x,y : longint);
{$ifdef GO32V2}
var
  regs : trealregs;
{$endif GO32V2}
begin
{$ifdef GO32V2}
  regs.realeax:=$0200;
  regs.realebx:=0;
  regs.realedx:=(y-1) shl 8+(x-1);
  realintr($10,regs);
{$else GO32V2}
  asm
        movb    $0x02,%ah
        movb    $0,%bh
        movb    y,%dh
        movb    x,%dl
        subw    $0x0101,%dx
        pushl   %ebp
        int     $0x10
        popl    %ebp
  end;
{$endif GO32V2}
end;


procedure GetScreenCursor(var x,y : longint);
begin
{$ifdef Go32V2}
  x:=mem[$40:$50]+1;
  y:=mem[$40:$51]+1;
{$else Go32V2}
  x:=0;
  y:=0;
  dosmemget($40,$50,x,1);
  dosmemget($40,$51,y,1);
  inc(x);
  inc(y);
{$endif GO32V2}
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:=(WindMax-WindMin=$184f);
end;


{****************************************************************************
                             Public Crt Functions
****************************************************************************}


procedure textmode(mode : integer);
begin
  lastmode:=mode;
  mode:=mode and $ff;
  setscreenmode(mode);
  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 $8f) or (TextAttr and $70);
End;



Procedure TextBackground(Color: Byte);
{
  Switch backgroundcolor
}
Begin
  TextAttr:=(Color shl 4) or (TextAttr and $0f);
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($b800,0,ScreenHeight*ScreenWidth,fil)
  else
   begin
     for y:=WinMinY to WinMaxY do
      DosmemFillWord($b800,((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($b800,((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;
{$ifdef GO32V2}
  regs : trealregs;
{$endif GO32V2}
begin
  if is_last then
   begin
     is_last:=false;
     readkey:=last;
   end
  else
   begin
{$ifdef GO32V2}
     regs.realeax:=$0000;
     realintr($16,regs);
     char1:=chr(regs.realeax and $ff);
     char2:=chr((regs.realeax and $ff00) shr 8);
{$else GO32V2}
     asm
        movb    $0,%ah
        pushl   %ebp
        int     $0x16
        popl    %ebp
        movb    %al,char1
        movb    %ah,char2
     end;
{$endif GO32V2}
     if char1=#0 then
      begin
        is_last:=true;
        last:=char2;
      end;
     readkey:=char1;
   end;
end;


function keypressed : boolean;
{$ifdef GO32V2}
var
  regs : trealregs;
{$endif GO32V2}
begin
  if is_last then
   begin
     keypressed:=true;
     exit;
   end
  else
   begin
{$ifdef GO32V2}
     regs.realeax:=$0100;
     realintr($16,regs);
     keypressed:=((regs.realflags and zeroflag) = 0);
{$else GO32V2}
     asm
        movb    $1,%ah
        pushl   %ebp
        int     $0x16
        popl    %ebp
        setnz   %al
        movb    %al,__RESULT
     end;
{$endif GO32V2}
   end;
end;


{*************************************************************************
                                   Delay
*************************************************************************}

{$ifdef VER0_99_5}

{ Workaround for ATT reader with CALL }
procedure Delayloop;
begin
  asm
.LDelayLoop1:
        subl    $1,%eax
        jc      .LDelayLoop2
        cmpl    %fs:(%edi),%ebx
        je      .LDelayLoop1
.LDelayLoop2:
  end;
end;


procedure initdelay;
begin
  asm
        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    _CRT$$_DELAYLOOP

        notl    %eax
        xorl    %edx,%edx
        movl    $55,%ecx
        divl    %ecx
        movl    %eax,_DELAYCNT
  end;
end;


procedure Delay(MS: Word);
begin
  asm
        movzwl  MS,%ecx
        jecxz   .LDelay2
        movl    $0x400,%edi
        movl    _DELAYCNT,%edx
        movl    %fs:(%edi),%ebx
.LDelay1:
        movl    %edx,%eax
        call    _CRT$$_DELAYLOOP
        loop    .LDelay1
.LDelay2:
  end;
end;

{$else}
procedure Delayloop;
begin
  asm
.LDelayLoop1:
        subl    $1,%eax
        jc      .LDelayLoop2
        cmpl    %fs:(%edi),%ebx
        je      .LDelayLoop1
.LDelayLoop2:
  end;
end;


procedure initdelay;
begin
  asm
        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;
end;


procedure Delay(MS: Word);
begin
  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;
end;

{$endif VER0_99_5}


procedure sound(hz : word);
begin
  if hz=0 then
   begin
     nosound;
     exit;
   end;
  asm
        movzwl  hz,%ecx
        movl    $1193046,%eax
        cdq
        divl    %ecx
        movl    %eax,%ecx
        movb    $0xb6,%al
        outb    %al,$0x43
        movb    %cl,%al
        outb    %al,$0x42
        movb    %ch,%al
        outb    %al,$0x42
        inb     $0x61,%al
        orb     $0x3,%al
        outb    %al,$0x61
  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($b800,(y*ScreenWidth+(WinMinX-1))*2,
                $b800,((y-1)*ScreenWidth+(WinMinX-1))*2,(WinMaxX-WinMinX+1)*2);
     inc(y);
   end;
  dosmemfillword($b800,((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-1;
  while (my>=y) do
   begin
     dosmemmove($b800,(((WinMinY+my-1)-1)*ScreenWidth+(WinMinX-1))*2,
                $b800,(((WinMinY+my)-1)*ScreenWidth+(WinMinX-1))*2,(WinMaxX-WinMinX+1)*2);
     dec(my);
   end;
  dosmemfillword($b800,(((WinMinY+y-1)-1)*ScreenWidth+(WinMinX-1))*2,(WinMaxX-WinMinX+1),fil);
end;




{****************************************************************************
                             Extra Crt Functions
****************************************************************************}

procedure cursoron;
{$ifdef GO32V2}
var
  regs : trealregs;
{$endif GO32V2}
begin
{$ifndef GO32V2}
  asm
        movb    $1,%ah
        movb    $10,%cl
        movb    $9,%ch
        pushl   %ebp
        int     $0x10
        popl    %ebp
  end;
{$else GO32V2}
  regs.realeax:=$0100;
  regs.realecx:=$90A;
  realintr($10,regs);
{$endif GO32V2}
end;


procedure cursoroff;
{$ifdef GO32V2}
var
  regs : trealregs;
{$endif GO32V2}
begin
{$ifdef GO32V2}
  regs.realeax:=$0100;
  regs.realecx:=$ffff;
  realintr($10,regs);
{$else GO32V2}
  asm
        movb    $1,%ah
        movb    $-1,%cl
        movb    $-1,%ch
        pushl   %ebp
        int     $0x10
        popl    %ebp
  end;
{$endif GO32V2}
end;


procedure cursorbig;
{$ifdef GO32V2}
var
  regs : trealregs;
{$endif GO32V2}
begin
{$ifdef GO32V2}
  regs.realeax:=$0100;
  regs.realecx:=$10A;
  realintr($10,regs);
{$else GO32V2}
  asm
        movb    $1,%ah
        movw    $110,%cx
        pushl   %ebp
        int     $0x10
        popl    %ebp
  end;
{$endif GO32V2}
end;


{*****************************************************************************
                          Read and Write routines
*****************************************************************************}

var
  CurrX,CurrY : longint;

Procedure WriteChar(c:char);
var
{$ifdef GO32V2}
  regs : trealregs;
{$else}
  chattr : word;
{$endif}
begin
  case c of
   #10 : inc(CurrY);
   #13 : CurrX:=WinMinX;
    #8 : begin
           if CurrX>WinMinX then
            dec(CurrX);
         end;
    #7 : begin { beep }
{$ifdef GO32V2}
           regs.dl:=7;
           regs.ah:=2;
           realintr($21,regs);
{$endif}
         end;
  else
   begin
{$ifdef GO32V2}
     memw[$b800:((CurrY-1)*ScreenWidth+(CurrX-1))*2]:=(textattr shl 8) or byte(c);
{$else}
     chattr:=(textattr shl 8) or byte(c);
     dosmemput($b800,((CurrY-1)*ScreenWidth+(CurrX-1))*2,chattr,2);
{$endif}
     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: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;


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);
{$ifdef GO32V2}
  TextAttr:=mem[$b800:((y-1)*ScreenWidth+(x-1))*2+1];
  lastmode:=mem[$40:$49];
{$else Go32V2}
  dosmemget($b800,((y-1)*ScreenWidth+(x-1))*2+1,TextAttr,1);
  dosmemget($40,$49,lastmode,1);
{$endif Go32V2}
{ Redirect the standard output }
  assigncrt(Output);
  Rewrite(Output);
  TextRec(Output).Handle:=StdOutputHandle;
  assigncrt(Input);
  Reset(Input);
  TextRec(Input).Handle:=StdInputHandle;
{ Calculates delay calibration }
  initdelay;
end.

{
  $Log$
  Revision 1.13  1998-08-26 10:01:54  peter
    * fixed readln cursor position

  Revision 1.12  1998/08/19 17:57:55  peter
    * fixed crtread with wrong cursor position

  Revision 1.11  1998/08/19 14:55:44  peter
    * fixed removeline which scrolled too much lines

  Revision 1.10  1998/08/18 13:32:46  carl
    * bugfix to make it work with FPC 0.99.5 (Delayloop is not correctly
  converted by ATT parser)

  Revision 1.9  1998/08/15 17:00:10  peter
    * moved delaycnt from interface to implementation

  Revision 1.8  1998/08/08 21:56:45  peter
    * updated crt with new delay, almost like bp7 routine

  Revision 1.5  1998/05/31 14:18:12  peter
    * force att or direct assembling
    * cleanup of some files

  Revision 1.4  1998/05/28 10:21:38  pierre
    * Handles of input and output restored

  Revision 1.3  1998/05/27 00:19:16  peter
    * fixed crt input

  Revision 1.2  1998/05/21 19:30:46  peter
    * objects compiles for linux
    + assign(pchar), assign(char), rename(pchar), rename(char)
    * fixed read_text_as_array
    + read_text_as_pchar which was not yet in the rtl
}