From 9b0f509242a50313d747ed794a9747f14335644c Mon Sep 17 00:00:00 2001
From: nickysn <nickysn@gmail.com>
Date: Sun, 27 Sep 2015 20:53:31 +0000
Subject: [PATCH] + initial implementation of a win16 crt unit, implemented on
 top of the video unit

git-svn-id: trunk@31863 -
---
 .gitattributes                        |   1 +
 packages/rtl-console/fpmake.pp        |   5 +-
 packages/rtl-console/src/win16/crt.pp | 534 ++++++++++++++++++++++++++
 3 files changed, 538 insertions(+), 2 deletions(-)
 create mode 100644 packages/rtl-console/src/win16/crt.pp

diff --git a/.gitattributes b/.gitattributes
index aaa8c222ce..b94d6c0e27 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -6807,6 +6807,7 @@ packages/rtl-console/src/win/keyboard.pp svneol=native#text/plain
 packages/rtl-console/src/win/mouse.pp svneol=native#text/plain
 packages/rtl-console/src/win/video.pp svneol=native#text/plain
 packages/rtl-console/src/win/winevent.pp svneol=native#text/plain
+packages/rtl-console/src/win16/crt.pp svneol=native#text/plain
 packages/rtl-console/src/win16/video.pp svneol=native#text/plain
 packages/rtl-extra/Makefile svneol=native#text/plain
 packages/rtl-extra/Makefile.fpc svneol=native#text/plain
diff --git a/packages/rtl-console/fpmake.pp b/packages/rtl-console/fpmake.pp
index 78b7997649..6b62bddaf7 100644
--- a/packages/rtl-console/fpmake.pp
+++ b/packages/rtl-console/fpmake.pp
@@ -16,13 +16,13 @@ Const
   KVMAll       = [emx,go32v2,netware,netwlibc,os2,win32,win64]+UnixLikes+AllAmigaLikeOSes;
   
   // all full KVMers have crt too, except Amigalikes
-  CrtOSes      = KVMALL+[msdos,WatCom]-[aros,morphos];
+  CrtOSes      = KVMALL+[msdos,WatCom,win16]-[aros,morphos];
   KbdOSes      = KVMALL+[msdos];
   VideoOSes    = KVMALL+[win16];
   MouseOSes    = KVMALL;
   TerminfoOSes = UnixLikes-[beos,haiku];
 
-  rtl_consoleOSes =KVMALL+CrtOSes+TermInfoOSes+[win16];
+  rtl_consoleOSes =KVMALL+CrtOSes+TermInfoOSes;
 
 // Amiga has a crt in its RTL dir, but it is commented in the makefile
 
@@ -99,6 +99,7 @@ begin
        AddInclude('crth.inc');
        AddInclude('crt.inc');
        AddInclude('nwsys.inc',[netware]);
+       AddUnit   ('video',[win16]);
      end;
 
     T:=P.Targets.AddUnit('vesamode.pp',[go32v2]);
diff --git a/packages/rtl-console/src/win16/crt.pp b/packages/rtl-console/src/win16/crt.pp
new file mode 100644
index 0000000000..919ee910bd
--- /dev/null
+++ b/packages/rtl-console/src/win16/crt.pp
@@ -0,0 +1,534 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2015 by the Free Pascal development team.
+
+    Borland Pascal 7 Compatible CRT Unit - Win16 implementation
+
+    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;
+
+{$GOTO on}
+
+interface
+
+{$i crth.inc}
+
+Var
+  ScreenWidth,
+  ScreenHeight : word;
+
+implementation
+
+uses
+  video;
+
+{****************************************************************************
+                           Low level Routines
+****************************************************************************}
+
+function GetScreenHeight : word;
+begin
+  getscreenheight:=video.ScreenHeight;
+end;
+
+
+function GetScreenWidth : word;
+begin
+  getscreenwidth:=video.ScreenWidth;
+end;
+
+
+procedure SetScreenCursor(x,y : smallint);
+begin
+  video.SetCursorPos(x-1,y-1);
+end;
+
+
+procedure GetScreenCursor(var x,y : smallint);
+begin
+  x:=video.CursorX+1;
+  y:=video.CursorY+1;
+end;
+
+
+{****************************************************************************
+                              Helper Routines
+****************************************************************************}
+
+var
+  WinMin: packed record
+    X, Y: Byte;
+  end absolute WindMin;
+
+  WinMax: packed record
+    X, Y: Byte;
+  end absolute WindMax;
+
+
+Function FullWin:boolean;
+{
+  Full Screen 80x25? Window(1,1,80,25) is used, allows faster routines
+}
+begin
+  FullWin:=(WinMin.X=0) and (WinMin.Y=0) and
+           (word(WinMax.X+1)=ScreenWidth) and (word(WinMax.Y+1)=ScreenHeight);
+end;
+
+
+{****************************************************************************
+                             Public Crt Functions
+****************************************************************************}
+
+
+procedure textmode (Mode: word);
+begin
+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: tcrtcoord; Y: tcrtcoord);
+{
+  Go to coordinates X,Y in the current window.
+}
+Begin
+  If (X>0) and (X<=WinMax.X- WinMin.X+1) and
+     (Y>0) and (Y<=WinMax.Y-WinMin.Y+1) Then
+   Begin
+     Inc(X,WinMin.X);
+     Inc(Y,WinMin.Y);
+     SetScreenCursor(x,y);
+   End;
+End;
+
+
+Procedure Window(X1, Y1, X2, Y2: Byte);
+{
+  Set screen window to the specified coordinates.
+}
+Begin
+  if (X1>X2) or (word(X2)>ScreenWidth) or
+     (Y1>Y2) or (word(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   : word;
+begin
+  fil:=32 or (textattr shl 8);
+  if FullWin then
+    FillWord(VideoBuf^,ScreenHeight*ScreenWidth,fil)
+  else
+    begin
+      for y:=WinMin.Y to WinMax.Y do
+        FillWord(VideoBuf^[y*ScreenWidth+word(WinMin.X)],WinMax.X-WinMin.X+1,fil);
+    end;
+  UpdateScreen(false);
+  Gotoxy(1,1);
+end;
+
+
+Procedure ClrEol;
+{
+  Clear from current position to end of line.
+}
+var
+  x,y : smallint;
+  fil : word;
+Begin
+  GetScreenCursor(x,y);
+  fil:=32 or (textattr shl 8);
+  if x<=(WinMax.X+1) then
+    begin
+      FillWord(VideoBuf^[(word(y-1)*ScreenWidth+word(x-1))],WinMax.X-x+2,fil);
+      UpdateScreen(false);
+    end;
+End;
+
+
+
+Function WhereX: tcrtcoord;
+{
+  Return current X-position of cursor.
+}
+var
+  x,y : smallint;
+Begin
+  GetScreenCursor(x,y);
+  WhereX:=x-WinMin.X;
+End;
+
+
+
+Function WhereY: tcrtcoord;
+{
+  Return current Y-position of cursor.
+}
+var
+  x,y : smallint;
+Begin
+  GetScreenCursor(x,y);
+  WhereY:=y-WinMin.Y;
+End;
+
+
+{*************************************************************************
+                            KeyBoard
+*************************************************************************}
+
+function readkey : char;
+begin
+end;
+
+
+function keypressed : boolean;
+begin
+end;
+
+
+{*************************************************************************
+                                   Delay
+*************************************************************************}
+
+procedure Delay(MS: Word);
+begin
+end;
+
+
+procedure sound(hz : word);
+begin
+end;
+
+
+procedure nosound;
+begin
+end;
+
+
+
+{****************************************************************************
+                          HighLevel Crt Functions
+****************************************************************************}
+
+procedure removeline(y : word);
+var
+  fil : word;
+begin
+  fil:=32 or (textattr shl 8);
+  y:=WinMin.Y+y;
+  While (y<=WinMax.Y) do
+    begin
+      Move(VideoBuf^[(y*ScreenWidth+word(WinMin.X))],
+           VideoBuf^[((y-1)*ScreenWidth+word(WinMin.X))],(WinMax.X-WinMin.X+1)*2);
+      inc(y);
+    end;
+  FillWord(VideoBuf^[(word(WinMax.Y)*ScreenWidth+word(WinMin.X))],(WinMax.X-WinMin.X+1),fil);
+end;
+
+
+procedure delline;
+begin
+  removeline(wherey);
+  UpdateScreen(false);
+end;
+
+
+procedure insline;
+var
+  my,y : smallint;
+  fil : word;
+begin
+  fil:=32 or (textattr shl 8);
+  y:=WhereY;
+  my:=WinMax.Y-WinMin.Y;
+  while (my>=y) do
+    begin
+      Move(VideoBuf^[(word(WinMin.Y+my-1)*ScreenWidth+word(WinMin.X))],
+           VideoBuf^[(word(WinMin.Y+my)*ScreenWidth+word(WinMin.X))],(WinMax.X-WinMin.X+1)*2);
+      dec(my);
+    end;
+  FillWord(VideoBuf^[(word(WinMin.Y+y-1)*ScreenWidth+word(WinMin.X))],(WinMax.X-WinMin.X+1),fil);
+  UpdateScreen(false);
+end;
+
+
+
+
+{****************************************************************************
+                             Extra Crt Functions
+****************************************************************************}
+
+procedure cursoron;
+begin
+  SetCursorType(crUnderLine);
+end;
+
+
+procedure cursoroff;
+begin
+  SetCursorType(crHidden);
+end;
+
+
+procedure cursorbig;
+begin
+  SetCursorType(crBlock);
+end;
+
+
+{*****************************************************************************
+                          Read and Write routines
+*****************************************************************************}
+
+var
+  CurrX,CurrY : smallint;
+
+Procedure WriteChar(c:char);
+begin
+  case c of
+   #10 : inc(CurrY);
+   #13 : CurrX:=WinMin.X+1;
+    #8 : begin
+           if CurrX>(WinMin.X+1) then
+            dec(CurrX);
+         end;
+    #7 : begin { beep }
+//           regs.dl:=7;
+//           regs.ah:=2;
+//           intr($21,regs);
+         end;
+  else
+   begin
+     VideoBuf^[word(CurrY-1)*ScreenWidth+word(CurrX-1)]:=(textattr shl 8) or byte(c);
+     inc(CurrX);
+   end;
+  end;
+  if CurrX>(WinMax.X+1) then
+   begin
+     CurrX:=(WinMin.X+1);
+     inc(CurrY);
+   end;
+  while CurrY>(WinMax.Y+1) do
+   begin
+     removeline(1);
+     dec(CurrY);
+   end;
+end;
+
+
+Procedure CrtWrite(var f : textrec);
+var
+  i : smallint;
+begin
+  GetScreenCursor(CurrX,CurrY);
+  for i:=0 to f.bufpos-1 do
+   WriteChar(f.buffer[i]);
+  SetScreenCursor(CurrX,CurrY);
+  f.bufpos:=0;
+  UpdateScreen(false);
+end;
+
+
+Procedure CrtRead(Var F: TextRec);
+
+  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
+           while f.bufpos<f.bufend do begin
+            WriteChar(f.bufptr^[f.bufpos]);
+            inc(f.bufpos);
+           end;
+           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);
+End;
+
+
+Procedure CrtReturn(Var F: TextRec);
+Begin
+end;
+
+
+Procedure CrtClose(Var F: TextRec);
+Begin
+  F.Mode:=fmClosed;
+End;
+
+
+Procedure CrtOpen(Var F: TextRec);
+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;
+End;
+
+
+procedure AssignCrt(var F: Text);
+begin
+  Assign(F,'');
+  TextRec(F).OpenFunc:=@CrtOpen;
+end;
+
+begin
+  InitVideo;
+{ Load startup values }
+  ScreenWidth:=GetScreenWidth;
+  ScreenHeight:=GetScreenHeight;
+  WindMax:=(ScreenWidth-1) or ((ScreenHeight-1) shl 8);
+  TextAttr:=$07;
+{ Redirect the standard output }
+  assigncrt(Output);
+  Rewrite(Output);
+  TextRec(Output).Handle:=StdOutputHandle;
+  assigncrt(Input);
+  Reset(Input);
+  TextRec(Input).Handle:=StdInputHandle;
+end.