123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884 |
- {
- This file is part of the Free Pascal run time library.
- Copyright (c) 1999-2000 by the Free Pascal development team.
- Borland Pascal 7 Compatible CRT Unit - Go32V2 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
- dos;
- {$ASMMODE INTEL}
- var
- DelayCnt : Longint;
- VidSeg : Word;
- {****************************************************************************
- Low level Routines
- ****************************************************************************}
- procedure dosmemfillword(segm, ofs: Word; count: Word; w: Word); assembler;
- asm
- mov ax, segm
- mov es, ax
- mov di, ofs
- mov ax, w
- mov cx, count
- rep stosw
- end;
- procedure dosmemmove(sseg, sofs, dseg, dofs: Word; count: Word); assembler;
- asm
- mov ax, dseg
- mov es, ax
- mov di, dofs
- mov si, sofs
- mov dx, count
- mov cx, dx
- mov ax, sseg
- push ds
- mov ds, ax
- shr cx, 1
- jz @@1
- rep movsw
- @@1:
- and dl, 1
- jz @@2
- rep movsb
- @@2:
- pop ds
- end;
- procedure setscreenmode(mode : byte);
- var
- regs : registers;
- begin
- regs.ax:=mode;
- intr($10,regs);
- end;
- function GetScreenHeight : word;
- begin
- getscreenheight:=mem[$40:$84]+1;
- If mem[$40:$84]=0 then
- getscreenheight := 25;
- end;
- function GetScreenWidth : word;
- begin
- getscreenwidth:=memw[$40:$4a];
- end;
- procedure SetScreenCursor(x,y : smallint);
- var
- regs : registers;
- begin
- regs.ax:=$0200;
- regs.bx:=0;
- regs.dx:=(y-1) shl 8+(x-1);
- intr($10,regs);
- end;
- procedure GetScreenCursor(var x,y : smallint);
- begin
- x:=mem[$40:$50]+1;
- y:=mem[$40:$51]+1;
- end;
- procedure DetectSnow;
- var
- regs: Registers;
- ega_switches: Byte;
- begin
- { the CGA snow bug exists only in 80x25 text modes. The 40x25 text modes and
- the graphics modes have no snow even on a true CGA. The monochrome 80x25
- text mode (lastmode=7) is not supported by CGA and is not snowy on every
- video card that support it (MDA, Hercules, EGA, VGA+) }
- if (lastmode<>2) and (lastmode<>3) then
- begin
- CheckSnow:=false;
- exit;
- end;
- { MCGA/VGA+ test }
- regs.ax:=$1A00;
- intr($10,regs);
- { function supported? }
- if regs.al=$1A then
- begin
- { at this point we have established that an MCGA or VGA+ card is present
- in the system. However there could still be two video cards present
- (i.e. an oldschool dual monitor configuration), and one of them could be
- a CGA, so check BL (=active display code) as well. }
- CheckSnow:=regs.bl=2;
- exit;
- end;
- { EGA test }
- regs.ah:=$12;
- regs.bx:=$FF10;
- intr($10,regs);
- { function supported? }
- if regs.bh<>$FF then
- begin
- ega_switches:=regs.cl and $0f;
- { in all the following cases a CGA card is also present and the EGA only
- works in monochrome mode, but we've already checked that we're not in a
- monochrome text mode (because lastmode<>7), so it must be the CGA
- currently active }
- CheckSnow:=(ega_switches=4) { primary CGA 40x25, secondary EGA+ 80x25 mono }
- or (ega_switches=5) { primary CGA 80x25, secondary EGA+ 80x25 mono }
- or (ega_switches=10) { primary EGA+ 80x25 mono, secondary CGA 40x25 (optional) }
- or (ega_switches=11); { primary EGA+ 80x25 mono, secondary CGA 80x25 (optional) }
- exit;
- end;
- CheckSnow:=true;
- 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);
- var
- regs : registers;
- begin
- lastmode:=mode;
- mode:=mode and $ff;
- setscreenmode(mode);
- { set 8x8 font }
- if (lastmode and $100)<>0 then
- begin
- regs.ax:=$1112;
- regs.bx:=$0;
- intr($10,regs);
- end;
- screenwidth:=getscreenwidth;
- screenheight:=getscreenheight;
- windmin:=0;
- windmax:=(screenwidth-1) or ((screenheight-1) shl 8);
- DetectSnow;
- 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
- DosmemFillWord(VidSeg,0,ScreenHeight*ScreenWidth,fil)
- else
- begin
- for y:=WinMin.Y to WinMax.Y do
- DosmemFillWord(VidSeg,(y*ScreenWidth+word(WinMin.X))*2,WinMax.X-WinMin.X+1,fil);
- end;
- 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
- DosmemFillword(VidSeg,(word(y-1)*ScreenWidth+word(x-1))*2,WinMax.X-x+2,fil);
- 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
- *************************************************************************}
- var
- keyboard_type: byte; { 0=83/84-key keyboard, $10=101/102+ keyboard }
- is_last : boolean;
- last : char;
- procedure DetectKeyboard;
- var
- regs: registers;
- begin
- keyboard_type:=0;
- if (Mem[$40:$96] and $10)<>0 then
- begin
- regs.ax:=$1200;
- intr($16,regs);
- if regs.ax<>$1200 then
- keyboard_type:=$10;
- end;
- end;
- function readkey : char;
- var
- char2 : char;
- char1 : char;
- regs : registers;
- begin
- if is_last then
- begin
- is_last:=false;
- readkey:=last;
- end
- else
- begin
- regs.ah:=keyboard_type;
- intr($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 : registers;
- begin
- if is_last then
- begin
- keypressed:=true;
- exit;
- end
- else
- begin
- regs.ah:=keyboard_type+1;
- intr($16,regs);
- keypressed:=((regs.flags and fZero) = 0);
- end;
- end;
- {*************************************************************************
- Delay
- *************************************************************************}
- procedure Delayloop;assembler;nostackframe;
- label
- LDelayLoop1, LDelayLoop2;
- asm
- { input:
- es:di = $40:$6c
- bx = value of [es:dx] before the call
- dx:ax = counter }
- LDelayLoop1:
- sub ax, 1
- sbb dx, 0
- jc .LDelayLoop2
- cmp bx, word es:[di]
- je .LDelayLoop1
- LDelayLoop2:
- end;
- procedure initdelay;
- label
- LInitDel1;
- begin
- 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
- mov ax, $40
- mov es, ax
- mov di, $6c
- mov bx, es:[di]
- LInitDel1:
- cmp bx, es:[di]
- je LInitDel1
- mov bx, es:[di]
- mov ax, $FFFF
- mov dx, $FFFF
- call DelayLoop
- mov [DelayCnt], ax
- mov [DelayCnt + 2], dx
- end ['AX','BX','DX', 'DI'];
- DelayCnt := -DelayCnt div $55;
- end;
- procedure Delay(MS: Word);assembler;
- label
- LDelay1, LDelay2;
- asm
- mov ax, $40
- mov es, ax
- xor di, di
- mov cx, MS
- test cx, cx
- jz LDelay2
- mov si, [DelayCnt + 2]
- mov bx, es:[di]
- LDelay1:
- mov ax, [DelayCnt]
- mov dx, si
- call DelayLoop
- loop LDelay1
- LDelay2:
- end;
- procedure sound(hz : word);
- label
- Lsound_next;
- begin
- if hz=0 then
- begin
- nosound;
- exit;
- end;
- asm
- mov cx, hz
- { dx:ax = 1193046 }
- mov ax, $3456
- mov dx, $12
- div cx
- mov cx, ax
- in al, $61
- test al, 3
- jnz Lsound_next
- or al, 3
- out $61, al
- mov al, $b6
- out $43, al
- Lsound_next:
- mov al, cl
- out $42, al
- mov al, ch
- out $42, al
- end ['AX','CX','DX'];
- end;
- procedure nosound; assembler; nostackframe;
- asm
- in al, $61
- and al, $fc
- out $61, al
- 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
- dosmemmove(VidSeg,(y*ScreenWidth+word(WinMin.X))*2,
- VidSeg,((y-1)*ScreenWidth+word(WinMin.X))*2,(WinMax.X-WinMin.X+1)*2);
- inc(y);
- end;
- dosmemfillword(VidSeg,(word(WinMax.Y)*ScreenWidth+word(WinMin.X))*2,(WinMax.X-WinMin.X+1),fil);
- end;
- procedure delline;
- begin
- removeline(wherey);
- 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
- dosmemmove(VidSeg,(word(WinMin.Y+my-1)*ScreenWidth+word(WinMin.X))*2,
- VidSeg,(word(WinMin.Y+my)*ScreenWidth+word(WinMin.X))*2,(WinMax.X-WinMin.X+1)*2);
- dec(my);
- end;
- dosmemfillword(VidSeg,(word(WinMin.Y+y-1)*ScreenWidth+word(WinMin.X))*2,(WinMax.X-WinMin.X+1),fil);
- end;
- {****************************************************************************
- Extra Crt Functions
- ****************************************************************************}
- procedure cursoron;
- var
- regs : registers;
- begin
- regs.ax:=$0100;
- If VidSeg=$b800 then
- regs.cx:=$0607
- else
- regs.cx:=$b0d;
- intr($10,regs);
- end;
- procedure cursoroff;
- var
- regs : registers;
- begin
- regs.ax:=$0100;
- regs.cx:=$2000;
- intr($10,regs);
- end;
- procedure cursorbig;
- var
- regs : registers;
- begin
- regs.ax:=$0100;
- regs.cx:=$0007;
- intr($10,regs);
- end;
- {*****************************************************************************
- Read and Write routines
- *****************************************************************************}
- var
- CurrX,CurrY : smallint;
- Procedure VidMemWriteWord(vidmem_offset,w: word);assembler;
- label
- in_retrace, no_retrace, no_snow, done;
- asm
- mov di, vidmem_offset
- xor ax, ax
- mov es, ax
- mov dx, es:[$463]
- add dx, 6 { DX = CRT Status Register }
- mov ax, VidSeg
- mov es, ax
- test CheckSnow, 1
- jz no_snow
- mov bx, w
- { time critical code follows }
- { if you ever need to change this code, make sure you test it on a real }
- { 4.77 MHz 8088 with an original IBM CGA card and make sure it doesn't }
- { produce snow }
- cli
- in_retrace:
- in al, dx
- shr al, 1
- jc in_retrace
- no_retrace:
- in al, dx
- shr al, 1
- jnc no_retrace
- xchg ax, bx
- stosw
- sti
- { time critical code ends here }
- jmp done
- { separate code path to avoid the unnecessary sti }
- no_snow:
- mov ax, w
- stosw
- done:
- end;
- Procedure WriteChar(c:char);
- var
- regs : registers;
- 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
- VidMemWriteWord((word(CurrY-1)*ScreenWidth+word(CurrX-1))*2,(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;
- 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;
- { 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 : smallint;
- begin
- { Detect keyboard type }
- DetectKeyboard;
- { 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;
- DetectSnow;
- If not(lastmode=Mono) then
- VidSeg := $b800
- else
- VidSeg := $b000;
- TextAttr:=mem[VidSeg:(word(y-1)*ScreenWidth+word(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.
|