+ basis for common platform independent implementation of Crt

rtl/inc/crt.inc

@@ -0,0 +1,417 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1998 - 2005 by the Free Pascal development team.
+
+    This file implements platform independent routines for Crt.
+    It should be modified later to use routines from Keyboard and
+    Video instead of code in platform-specific crt.pas.
+
+    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.
+
+ **********************************************************************}
+
+procedure GotoXY (X: byte; Y: byte);
+begin
+ GotoXY32 (X, Y);
+end;
+
+procedure Window (X1, Y1, X2, Y2: byte);
+begin
+ Window32 (X1, Y1, X2, Y2);
+end;
+
+function WhereX: byte;
+var
+ X1: dword;
+begin
+ X1 := WhereX32;
+ if X1 > 255 then
+  WhereX := 255
+ else
+  WhereX := X1;
+end;
+
+function WhereY: byte;
+var
+ Y1: dword;
+begin
+ Y1 := WhereY32;
+ if Y1 > 255 then
+  WhereY := 255
+ else
+  WhereY := Y1;
+end;
+
+
+procedure ClrScr;
+{Clears the current window.}
+begin
+ RemoveLines (0, Succ (WindMaxY - WindMinY));
+ GotoXY32 (1, 1);
+end;
+
+
+procedure GotoXY32 (X, Y: dword);
+(* Positions cursor on (X, Y) (1-based) relative to window origin; for TP/BP
+   compatibility call completely ignored in case of incorrect parameters.    *)
+begin
+ if (X > 0) and (Y > 0) then
+  begin
+   Dec (X);
+   Dec (Y);
+   if (X <= WindMaxX - WindMinX) and (Y <= WindMaxY - WindMinY) then
+    SetScreenCursor (X + WindMinX, Y + WindMinY);
+  end;
+end;
+
+
+function WhereX32: dword;
+(* Returns the X position of the cursor (1-based). *)
+var
+ X, Y: dword;
+begin
+ GetScreenCursor (X, Y);
+ WhereX32 := Succ (X - WindMinX);
+end;
+
+
+function WhereY32: dword;
+(* Returns the Y position of the cursor (1-based). *)
+var
+ X, Y: dword;
+begin
+ GetScreenCursor (X, Y);
+ WhereY32 := Succ (Y - WindMinY);
+end;
+
+
+procedure ClrEol;
+(* Clears the line where cursor is located from current position up to end. *)
+var
+ X, Y: dword;
+begin
+ GetScreenCursor (X, Y);
+ ClearCells (X, Y, Succ (WindMaxX - X));
+end;
+
+
+procedure DelLine;
+(* Deletes the line at cursor. *)
+begin
+ RemoveLines (Pred (WhereY32), 1);
+end;
+
+
+procedure TextMode (Mode: word);
+{ Use this procedure to set-up a specific text-mode.}
+begin
+ TextAttr := $07;
+ LastMode := Mode;
+ SetScreenMode (Mode);
+ WindMin := 0;
+ WindMaxX := Pred (ScreenWidth);
+ WindMaxY := Pred (ScreenHeight);
+ if WindMaxX >= 255 then
+  WindMax := 255
+ else
+  WindMax := WindMaxX;
+ if WindMaxY >= 255 then
+  WindMax := WindMax or $FF00
+ else
+  WindMax := WindMax or (WindMaxY shl 8);
+ ClrScr;
+end;
+
+
+procedure TextColor (Color: byte);
+{All text written after calling this will have Color as foreground colour.}
+begin
+ TextAttr := (TextAttr and $70) or (Color and $f);
+ if Color > 15 then
+  TextAttr := TextAttr or 128;
+end;
+
+
+procedure TextBackground (Color: byte);
+{All text written after calling this will have Color as background colour.}
+begin
+ TextAttr := (TextAttr and $8F) or ((Color and $7) shl 4);
+end;
+
+
+procedure NormVideo;
+{Changes the text-background to black and the foreground to white.}
+begin
+ TextAttr := $7;
+end;
+
+
+procedure LowVideo;
+{All text written after this will have low intensity.}
+begin
+ TextAttr := TextAttr and $F7;
+end;
+
+
+procedure HighVideo;
+{All text written after this will have high intensity.}
+begin
+ TextAttr := TextAttr or $8;
+end;
+
+
+procedure Window32 (X1, Y1, X2, Y2: dword);
+{Change the write window to the given coordinates.}
+begin
+ if (X1 > 0) and (Y1 > 0) and (X2 <= ScreenWidth) and (Y2 <= ScreenHeight)
+                                             and (X1 <= X2) and (Y1 <= Y2) then
+  begin
+   WindMinX := Pred (X1);
+   WindMinY := Pred (Y1);
+   if WindMinX >= 255 then
+    WindMin := 255
+   else
+    WindMin := WindMinX;
+   if WindMinY >= 255 then
+    WindMin := WindMin or $FF00
+   else
+    WindMin := WindMin or (WindMinY shl 8);
+   WindMaxX := Pred (X2);
+   WindMaxY := Pred (Y2);
+   if WindMaxX >= 255 then
+    WindMax := 255
+   else
+    WindMax := WindMaxX;
+   if WindMaxY >= 255 then
+    WindMax := WindMax or $FF00
+   else
+    WindMax := WindMaxX or (WindMaxY shl 8);
+   GotoXY32 (1, 1);
+  end;
+end;
+
+
+{$ifdef HASTHREADVAR}
+threadvar
+{$else HASTHREADVAR}
+var
+{$endif HASTHREADVAR}
+ CurrX, CurrY: dword;
+
+
+procedure WriteChar (C: char);
+begin
+ case C of
+  #7: WriteBell;
+  #8: if CurrX >= WindMinX then
+       Dec (CurrX);
+{      #9: x:=(x-lo(windmin)) and $fff8+8+lo(windmin);}
+  #10: Inc (CurrY);
+  #13: CurrX := WindMinX;
+  else
+   begin
+    WriteNormal (C, CurrX, CurrY);
+    Inc (CurrX);
+   end;
+ end;
+ if CurrX > WindMaxX then
+  begin
+   CurrX := WindMinX;
+   Inc (CurrY);
+  end;
+ if CurrY > WindMaxY then
+  begin
+   RemoveLines (0, 1);
+   CurrY := WindMaxY;
+  end;
+end;
+
+
+function CrtWrite (var F: TextRec): integer;
+var
+ I: dword;
+{Write a series of characters to the console.}
+begin
+ if F.BufPos > 0 then
+  begin
+   GetScreenCursor (CurrX, CurrY);
+   for I := 0 to Pred (F.BufPos) do
+    WriteChar ((PChar (F.BufPtr) + I)^);
+   SetScreenCursor (CurrX, CurrY);
+   F.BufPos := 0;
+  end;
+ CrtWrite := 0;
+end;
+
+
+function CrtRead (var F: TextRec): integer;
+{Read a series of characters from the console.}
+var
+ C: 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);
+  C := ReadKey;
+  case C of
+   #0: ReadKey;
+(* The following code to support input editing is incomplete anyway
+   - no handling of line breaks, no possibility to insert characters
+   or delete characters inside the string, etc.
+
+   #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;
+*)
+
+   #8: if (F.BufPos > 0) and (F.BufPos = F.BufEnd) then
+        begin
+{$WARNING CrtRead doesn't handle line breaks correctly (same bug as TP/BP)!}
+         WriteChar (#8);
+         WriteChar (' ');
+         WriteChar (#8);
+         Dec (F.BufPos);
+         Dec (F.BufEnd);
+        end;
+   #13: begin
+         WriteChar(#13);
+         WriteChar(#10);
+         F.BufPtr^ [F.BufEnd] := #13;
+         Inc (F.BufEnd);
+         F.BufPtr^ [F.BufEnd] := #10;
+         Inc (F.BufEnd);
+         break;
+        end;
+   #26: if CheckEOF then
+         begin
+          F.BufPtr^ [F.BufEnd] := #26;
+          Inc (F.BufEnd);
+          break;
+         end;
+   #32..#255: if F.BufPos < F.BufSize - 2 then
+               begin
+                F.BufPtr^ [F.BufPos] := C;
+                Inc (F.BufPos);
+                WriteChar (C);
+               end;
+  end
+ until false;
+ 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);
+{Assigns a file to the crt console.}
+begin
+ Assign (F, '');
+ TextRec (F).OpenFunc := @CrtOpen;
+end;
+
+
+{$IFNDEF HAS_SOUND}
+procedure Sound (Hz: word);
+(* Dummy Sound implementation - for platforms requiring both frequence
+   and duration at the beginning instead of start and stop procedures. *)
+begin
+end;
+{$ENDIF HAS_SOUND}
+
+
+{$IFNDEF HAS_NOSOUND}
+procedure NoSound;
+(* Dummy NoSound implementation - for platforms requiring both frequence
+   and duration at the beginning instead of start and stop procedures.   *)
+begin
+end;
+{$ENDIF HAS_NOSOUND}
+
+
+procedure CrtInit;
+(* Common part of unit initialization. *)
+begin
+ TextAttr := LightGray;
+ WindMin := 0;
+ WindMaxX := Pred (ScreenWidth);
+ WindMaxY := Pred (ScreenHeight);
+ if WindMaxX >= 255 then
+  WindMax := 255
+ else
+  WindMax := WindMaxX;
+ if WindMaxY >= 255 then
+  WindMax := WindMax or $FF00
+ else
+  WindMax := WindMax or (WindMaxY shl 8);
+ ExtKeyCode := #0;
+ AssignCrt (Input);
+ Reset (Input);
+ AssignCrt (Output);
+ Rewrite (Output);
+end;
+
+{
+  $Log$
+  Revision 1.1  2005-05-14 14:32:55  hajny
+    + basis for common platform independent implementation of Crt
+
+
+}