mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-07-31 19:46:03 +02:00
565 lines
16 KiB
PHP
565 lines
16 KiB
PHP
{
|
|
System independent low-level video interface for OS/2
|
|
|
|
$Id$
|
|
|
|
}
|
|
|
|
uses
|
|
{$IFDEF PPC_FPC}
|
|
DosCalls, VioCalls;
|
|
{$ELSE}
|
|
{$IFDEF PPC_VIRTUAL}
|
|
Os2Base;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF FPC}
|
|
type
|
|
cardinal = longint;
|
|
{$ENDIF}
|
|
|
|
const
|
|
InitVideoCalled: boolean = false;
|
|
LastCursorType: word = crUnderline;
|
|
EmptyCell: cardinal = $0720;
|
|
OrigScreen: PVideoBuf = nil;
|
|
OrigScreenSize: cardinal = 0;
|
|
|
|
{$IFDEF PPC_VIRTUAL}
|
|
type
|
|
TVioCursorInfo = VioCursorInfo;
|
|
TVioModeInfo = VioModeInfo;
|
|
TVioIntensity = VioIntensity;
|
|
{$ENDIF}
|
|
|
|
var OrigCurType: TVioCursorInfo;
|
|
OrigVioMode: TVioModeInfo;
|
|
OrigHighBit: TVioIntensity;
|
|
OrigCurRow: word;
|
|
OrigCurCol: word;
|
|
CellHeight: byte;
|
|
OldVideoBuf: PVideoBuf;
|
|
|
|
procedure TargetEntry;
|
|
|
|
var P: PVideoModeList;
|
|
PScr: pointer;
|
|
|
|
begin
|
|
{Remember original video mode, cursor type and high bit behaviour setting}
|
|
OrigVioMode.cb := SizeOf (OrigVioMode);
|
|
VioGetMode (OrigVioMode, 0);
|
|
VioGetCurType (OrigCurType, 0);
|
|
VioGetCurPos (OrigCurRow, OrigCurCol, 0);
|
|
with OrigHighBit do
|
|
begin
|
|
cb := 6;
|
|
rType := 2;
|
|
end;
|
|
VioGetState (OrigHighBit, 0);
|
|
{Register the curent video mode in Modes if not there yet}
|
|
with OrigVioMode do
|
|
begin
|
|
P := Modes;
|
|
while (P <> nil) and ((P^.Row <> Row) or (P^.Col <> Col)
|
|
or (P^.Color <> (Color >= Colors_16))) do
|
|
P := P^.Next;
|
|
if P = nil then
|
|
{Assume we have at least 16 colours available in "colour" modes}
|
|
RegisterVideoMode (Col, Row, Color >= Colors_16,
|
|
{$IFDEF FPC}
|
|
@DefaultVideoModeSelector, 0);
|
|
{$ELSE}
|
|
DefaultVideoModeSelector, 0);
|
|
{$ENDIF}
|
|
end;
|
|
{Get the address of the original videobuffer and size.}
|
|
if VioGetBuf (PScr, PWord (@OrigScreenSize)^, 0) = 0 then
|
|
begin
|
|
{$IFDEF BIT_32}
|
|
{$IFDEF PPC_VIRTUAL}
|
|
SelToFlat (PScr);
|
|
{$ELSE}
|
|
PScr := SelToFlat (TFarPtr (PScr));
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
GetMem (OrigScreen, OrigScreenSize);
|
|
Move (PScr^, OrigScreen^, OrigScreenSize);
|
|
end;
|
|
end;
|
|
|
|
procedure TargetExit;
|
|
|
|
begin
|
|
end;
|
|
|
|
|
|
procedure CheckCellHeight;
|
|
|
|
var OldCD, CD: TVioCursorInfo;
|
|
|
|
begin
|
|
VioGetCurType (OldCD, 0);
|
|
Move (OldCD, CD, SizeOf (CD));
|
|
with CD do
|
|
begin
|
|
Attr := 0;
|
|
yStart := word (-90);
|
|
cEnd := word (-100);
|
|
end;
|
|
VioSetCurType (CD, 0);
|
|
VioGetCurType (CD, 0);
|
|
CellHeight := CD.cEnd;
|
|
VioSetCurType (OldCD, 0);
|
|
end;
|
|
|
|
|
|
procedure RegisterVideoModes;
|
|
begin
|
|
{ BW modes are rejected on my (colour) configuration. I can't imagine
|
|
OS/2 running on MCGA anyway... ;-)
|
|
|
|
RegisterVideoMode (40, 25, False, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 25, False, @DefaultVideoModeSelector, 0);
|
|
}
|
|
{$IFDEF FPC}
|
|
RegisterVideoMode (40, 25, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 25, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 30, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 43, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 50, True, @DefaultVideoModeSelector, 0);
|
|
{$ELSE}
|
|
RegisterVideoMode (40, 25, True, DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 25, True, DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 30, True, DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 43, True, DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 50, True, DefaultVideoModeSelector, 0);
|
|
{$ENDIF}
|
|
|
|
{ The following modes wouldn't work on plain VGA; is it useful to check
|
|
for their availability on the program startup?
|
|
|
|
RegisterVideoMode (132, 25, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (132, 30, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (132, 43, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (132, 50, True, @DefaultVideoModeSelector, 0);
|
|
}
|
|
end;
|
|
|
|
|
|
procedure SetHighBitBlink (Blink: boolean);
|
|
|
|
var VI: TVioIntensity;
|
|
|
|
begin
|
|
with VI do
|
|
begin
|
|
cb := 6;
|
|
rType := 2;
|
|
fs := byte (not (Blink));
|
|
end;
|
|
VioSetState (VI, 0);
|
|
end;
|
|
|
|
|
|
procedure InitVideo;
|
|
|
|
var MI: TVioModeInfo;
|
|
|
|
begin
|
|
if InitVideoCalled then
|
|
FreeMem (OldVideoBuf, VideoBufSize);
|
|
OldVideoBuf := nil;
|
|
InitVideoCalled := true;
|
|
VideoBufSize := 0;
|
|
MI.cb := SizeOf (MI);
|
|
VioGetMode (MI, 0);
|
|
with MI do
|
|
begin
|
|
ScreenWidth := Col;
|
|
ScreenHeight := Row;
|
|
ScreenColor := Color >= Colors_16;
|
|
end;
|
|
VioGetCurPos (CursorY, CursorX, 0);
|
|
LowAscii := true;
|
|
SetCursorType (LastCursorType);
|
|
{Get the address of the videobuffer.}
|
|
{$IFDEF PPC_VIRTUAL}
|
|
if VioGetBuf (pointer (VideoBuf), PWord (@VideoBufSize)^, 0) = 0 then
|
|
begin
|
|
SelToFlat (pointer (VideoBuf));
|
|
{$ELSE}
|
|
if VioGetBuf (VideoBuf, PWord (@VideoBufSize)^, 0) = 0 then
|
|
begin
|
|
{$IFDEF BIT_32}
|
|
VideoBuf := SelToFlat (TFarPtr (VideoBuf));
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
SetHighBitBlink (true);
|
|
GetMem (OldVideoBuf, VideoBufSize);
|
|
Move (VideoBuf^, OldVideoBuf^, VideoBufSize);
|
|
end
|
|
else
|
|
ErrorHandler (errVioInit, nil);
|
|
end;
|
|
|
|
|
|
procedure SetCursorPos (NewCursorX, NewCursorY: word);
|
|
|
|
begin
|
|
if VioSetCurPos (NewCursorY, NewCursorX, 0) = 0 then
|
|
begin
|
|
CursorX := NewCursorX;
|
|
CursorY := NewCursorY;
|
|
end
|
|
else
|
|
{Do not set an error code; people should fix invalid NewCursorX
|
|
or NewCursorY values when designing, there is no need for detecting
|
|
these errors at runtime.}
|
|
RunError (225);
|
|
end;
|
|
|
|
|
|
function GetCursorType: word;
|
|
|
|
var CD: TVioCursorInfo;
|
|
|
|
begin
|
|
VioGetCurType (CD, 0); {Never fails, because handle is default handle.}
|
|
with CD do
|
|
begin
|
|
CursorLines := Succ (cEnd) - yStart;
|
|
if Attr = word (-1) then
|
|
GetCursorType := crHidden
|
|
else
|
|
{Because the cursor's start and end lines are returned, we'll have
|
|
to guess heuristically what cursor type we have.}
|
|
if CursorLines = 0 then
|
|
{Probably this does not occur, but you'll never know.}
|
|
GetCursorType := crHidden
|
|
else if CursorLines <= Succ (CellHeight div 4) then
|
|
GetCursorType := crUnderline
|
|
else if CursorLines <= Succ (CellHeight div 2) then
|
|
GetCursorType := crHalfBlock
|
|
else
|
|
GetCursorType := crBlock;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure SetCursorType (NewType: word);
|
|
|
|
var CD: TVioCursorInfo;
|
|
|
|
begin
|
|
VioGetCurType (CD, 0);
|
|
with CD do
|
|
begin
|
|
case NewType of
|
|
crHidden: Attr := word (-1);
|
|
crUnderline:
|
|
begin
|
|
Attr := 0;
|
|
yStart := word (-90);
|
|
cEnd := word (-100);
|
|
end;
|
|
crHalfBlock:
|
|
begin
|
|
Attr := 0;
|
|
yStart := word (-50);
|
|
cEnd := word (-100);
|
|
end;
|
|
crBlock:
|
|
begin
|
|
Attr := 0;
|
|
yStart := 0;
|
|
cEnd := word (-100);
|
|
end;
|
|
end;
|
|
VioSetCurType (CD, 0);
|
|
VioGetCurType (CD, 0);
|
|
CursorLines := Succ (cEnd) - yStart;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure DoneVideo;
|
|
|
|
var PScr: pointer;
|
|
ScrSize: cardinal;
|
|
|
|
begin
|
|
if InitVideoCalled then
|
|
begin
|
|
LastCursorType := GetCursorType;
|
|
ClearScreen;
|
|
{Restore original settings}
|
|
VioSetMode (OrigVioMode, 0);
|
|
CheckCellHeight;
|
|
{Set CursorX and CursorY}
|
|
SetCursorPos (0, 0);
|
|
VioSetState (OrigHighBit, 0);
|
|
VioSetCurType (OrigCurType, 0);
|
|
VioSetCurPos (OrigCurRow, OrigCurCol, 0);
|
|
FreeMem (OldVideoBuf, VideoBufSize);
|
|
OldVideoBuf := nil;
|
|
VideoBufSize := 0;
|
|
InitVideoCalled := false;
|
|
if (OrigScreenSize <> 0) and (OrigScreen <> nil) then
|
|
begin
|
|
ScrSize := 0;
|
|
if (VioGetBuf (PScr, PWord (@ScrSize)^, 0) = 0)
|
|
and (ScrSize = OrigScreenSize) then
|
|
begin
|
|
{$IFDEF BIT_32}
|
|
{$IFDEF PPC_VIRTUAL}
|
|
SelToFlat (PScr);
|
|
{$ELSE}
|
|
PScr := SelToFlat (TFarPtr (PScr));
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
Move (OrigScreen^, PScr^, OrigScreenSize);
|
|
VioShowBuf (0, ScrSize, 0);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function GetCapabilities: word;
|
|
|
|
begin
|
|
GetCapabilities := $3F;
|
|
end;
|
|
|
|
|
|
function DefaultVideoModeSelector (const VideoMode: TVideoMode; Params: longint): boolean;
|
|
|
|
var OldMI, MI: TVioModeInfo;
|
|
|
|
begin
|
|
OldMI.cb := SizeOf (OldMI);
|
|
if VioGetMode (OldMI, 0) <> 0 then
|
|
DefaultVideoModeSelector := false
|
|
else
|
|
begin
|
|
with MI do
|
|
begin
|
|
cb := 8;
|
|
fbType := 1;
|
|
if VideoMode.Color then
|
|
Color := Colors_16
|
|
else
|
|
Color := Colors_2;
|
|
Col := VideoMode.Col;
|
|
Row := VideoMode.Row;
|
|
end;
|
|
if VioSetMode (MI, 0) = 0 then
|
|
{$IFDEF PPC_VIRTUAL}
|
|
if VioGetBuf (pointer (VideoBuf),
|
|
PWord (@VideoBufSize)^, 0) = 0 then
|
|
begin
|
|
SelToFlat (pointer (VideoBuf));
|
|
{$ELSE}
|
|
if VioGetBuf (VideoBuf, PWord (@VideoBufSize)^, 0) = 0 then
|
|
begin
|
|
{$IFDEF BIT_32}
|
|
VideoBuf := SelToFlat (TFarPtr (VideoBuf));
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
DefaultVideoModeSelector := true;
|
|
SetHighBitBlink (true);
|
|
CheckCellHeight;
|
|
SetCursorType (LastCursorType);
|
|
ClearScreen;
|
|
end
|
|
else
|
|
begin
|
|
DefaultVideoModeSelector := false;
|
|
VioSetMode (OldMI, 0);
|
|
{$IFDEF PPC_VIRTUAL}
|
|
VioGetBuf (pointer (VideoBuf),
|
|
PWord (@VideoBufSize)^, 0);
|
|
SelToFlat (pointer (VideoBuf));
|
|
{$ELSE}
|
|
VioGetBuf (VideoBuf, PWord (@VideoBufSize)^, 0);
|
|
{$IFDEF BIT_32}
|
|
VideoBuf := SelToFlat (TFarPtr (VideoBuf));
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
SetHighBitBlink (true);
|
|
CheckCellHeight;
|
|
SetCursorType (LastCursorType);
|
|
ClearScreen;
|
|
end
|
|
else
|
|
begin
|
|
DefaultVideoModeSelector := false;
|
|
{$IFDEF PPC_VIRTUAL}
|
|
VioGetBuf (pointer (VideoBuf), PWord (@VideoBufSize)^, 0);
|
|
SelToFlat (pointer (VideoBuf));
|
|
{$ELSE}
|
|
VioGetBuf (VideoBuf, PWord (@VideoBufSize)^, 0);
|
|
{$IFDEF BIT_32}
|
|
VideoBuf := SelToFlat (TFarPtr (VideoBuf));
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
SetHighBitBlink (true);
|
|
SetCursorType (LastCursorType);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure ClearScreen;
|
|
|
|
begin
|
|
VioScrollDn (0, 0, word (-1), word (-1), word (-1), PWord (@EmptyCell)^, 0);
|
|
Move (VideoBuf^, OldVideoBuf^, VideoBufSize);
|
|
end;
|
|
|
|
|
|
{$IFDEF PPC_FPC}
|
|
{$ASMMODE INTEL}
|
|
{$ENDIF}
|
|
|
|
procedure UpdateScreen (Force: boolean);
|
|
|
|
{$IFDEF BIT_32}
|
|
var SOfs, CLen: cardinal;
|
|
{$ELSE}
|
|
var SOfs, CLen: word;
|
|
{$ENDIF}
|
|
|
|
begin
|
|
if LockUpdateScreen = 0 then
|
|
begin
|
|
if not (Force) then
|
|
begin
|
|
{$IFDEF BIT_32}
|
|
asm
|
|
cld
|
|
mov esi, VideoBuf
|
|
mov edi, OldVideoBuf
|
|
mov eax, VideoBufSize
|
|
mov ecx, eax
|
|
shr ecx
|
|
shr ecx
|
|
repe
|
|
cmpsd
|
|
inc cx
|
|
mov SOfs, ecx
|
|
or ecx, ecx
|
|
jz @no_update
|
|
mov Force, 1
|
|
std
|
|
mov edi, eax
|
|
mov esi, VideoBuf
|
|
add eax, esi
|
|
sub eax, 4
|
|
mov esi, eax
|
|
mov eax, OldVideoBuf
|
|
add eax, edi
|
|
sub eax, 4
|
|
mov edi, eax
|
|
repe
|
|
cmpsd
|
|
inc ecx
|
|
shl ecx
|
|
shl ecx
|
|
mov CLen, ecx
|
|
cld
|
|
@no_update:
|
|
end;
|
|
SOfs := VideoBufSize - (SOfs shl 2);
|
|
{$ELSE}
|
|
asm
|
|
cld
|
|
push ds
|
|
lds si, VideoBuf
|
|
les di, OldVideoBuf
|
|
mov ax, word ptr VideoBufSize
|
|
mov cx, ax
|
|
shr cx
|
|
repe
|
|
cmpsw
|
|
inc cx
|
|
mov SOfs, cx
|
|
or cx, cx
|
|
jz @no_update
|
|
mov Force, 1
|
|
std
|
|
mov di, ax
|
|
mov si, offset VideoBuf
|
|
add ax, si
|
|
dec ax
|
|
dec ax
|
|
mov si, ax
|
|
mov ax, offset OldVideoBuf
|
|
add ax, di
|
|
dec ax
|
|
dec ax
|
|
mov di, ax
|
|
repe
|
|
cmpsw
|
|
inc cx
|
|
shl cx
|
|
mov CLen, cx
|
|
cld
|
|
@no_update:
|
|
pop ds
|
|
end;
|
|
Inc (SOfs);
|
|
SOfs := VideoBufSize - (SOfs shl 1);
|
|
{$ENDIF}
|
|
end else
|
|
begin
|
|
SOfs := 0;
|
|
CLen := VideoBufSize;
|
|
end;
|
|
if Force then
|
|
begin
|
|
VioShowBuf (SOfs, CLen, 0);
|
|
Move (VideoBuf^ [SOfs div SizeOf (TVideoCell)],
|
|
OldVideoBuf^ [SOfs div SizeOf (TVideoCell)], CLen);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
{
|
|
|
|
$Log$
|
|
Revision 1.11 2000-10-15 20:52:56 hajny
|
|
* optimization of UpdateScreen finished
|
|
|
|
Revision 1.10 2000/10/11 20:10:04 hajny
|
|
* compatibility enhancements
|
|
|
|
Revision 1.9 2000/10/11 05:28:29 hajny
|
|
* really a faster version now ;-)
|
|
|
|
Revision 1.8 2000/10/10 20:28:18 hajny
|
|
* screen updates speeded up
|
|
|
|
Revision 1.7 2000/10/08 18:40:58 hajny
|
|
* SetCursorType corrected
|
|
|
|
Revision 1.6 2000/10/08 14:13:19 hajny
|
|
* ClearScreen correction, screen restored on exit
|
|
|
|
Revision 1.5 2000/10/04 11:53:31 pierre
|
|
Add TargetEntry and TargetExit (merged)
|
|
|
|
Revision 1.4 2000/09/26 18:15:29 hajny
|
|
+ working with VP/2 already (not FPC yet)!
|
|
|
|
Revision 1.3 2000/09/24 19:53:03 hajny
|
|
* OS/2 implementation almost finished, not debugged yet
|
|
|
|
Revision 1.2 2000/07/13 11:32:26 michael
|
|
+ removed logs
|
|
|
|
}
|