Why Gemfury?
Push, build, and install
RubyGems
npm packages
Python packages
Maven artifacts
PHP packages
Go Modules
Debian packages
RPM packages
NuGet packages
Repository URL to install this package:
|
Version:
3.2.0 ▾
|
{
This file is part of the PTCPas framebuffer library
Copyright (C) 2001-2010 Nikolay Nikolov (nickysn@users.sourceforge.net)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version
with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,and
to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify
this library, you may extend this exception to your version of the library,
but you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
This library 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. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
}
{$MODE objfpc}{$H+}
{$ASMMODE intel}
unit VESA;
interface
type
TVesaModeInfoBlock = packed record
{Mandatory information for all VBE revisions}
ModeAttributes: Word; {mode attributes}
WinAAttributes: Byte; {window A attributes}
WinBAttributes: Byte; {window B attributes}
WinGranularity: Word; {window granularity}
WinSize: Word; {window size}
WinASegment: Word; {window A start segment}
WinBSegment: Word; {window B start segment}
WinFuncPtr: DWord; {real mode pointer to window function}
BytesPerScanLine: Word; {bytes per scan line}
{Mandatory information for VBE 1.2 and above}
XResolution: Word; {horizontal resolution in pixels or characters}
YResolution: Word; {vertical resolution in pixels or characters}
XCharSize: Byte; {character cell width in pixels}
YCharSize: Byte; {character cell height in pixels}
NumberOfPlanes: Byte; {number of memory planes}
BitsPerPixel: Byte; {bits per pixel}
NumberOfBanks: Byte; {number of banks}
MemoryModel: Byte; {memory model type}
BankSize: Byte; {bank size in KB}
NumberOfImagePages: Byte; {number of images}
Reserved: Byte;{=1} {reserved for page function}
{Direct color fields (required for direct/6 and YUV/7 memory models)}
RedMaskSize: Byte; {size of direct color red mask in bits}
RedFieldPosition: Byte; {bit position of lsb of red mask}
GreenMaskSize: Byte; {size of direct color green mask in bits}
GreenFieldPosition: Byte; {bit position of lsb of green mask}
BlueMaskSize: Byte; {size of direct color blue mask in bits}
BlueFieldPosition: Byte; {bit position of lsb of blue mask}
RsvdMaskSize: Byte; {size of direct color reserved mask in bits}
RsvdFieldPosition: Byte; {bit position of lsb of reserved mask}
DirectColorModeInfo: Byte; {direct color mode attributes}
{Mandatory information for VBE 2.0 and above}
PhysBasePtr: DWord; {physical address for flat memory frame buffer}
Reserved2: DWord;{=0} {Reserved - always set to 0}
Reserved3: Word;{=0} {Reserved - always set to 0}
{Mandatory information for VBE 3.0 and above}
LinBytesPerScanLine: Word; {bytes per scan line for linear modes}
BnkNumberOfImagePages: Byte; {number of images for banked modes}
LinNumberOfImagePages: Byte; {number of images for linear modes}
LinRedMaskSize: Byte; {size of direct color red mask (linear modes)}
LinRedFieldPosition: Byte; {bit position of lsb of red mask (linear modes)}
LinGreenMaskSize: Byte; {size of direct color green mask (linear modes)}
LinGreenFieldPosition: Byte; {bit position of lsb of green mask (linear modes)}
LinBlueMaskSize: Byte; {size of direct color blue mask (linear modes)}
LinBlueFieldPosition: Byte; {bit position of lsb of blue mask (linear modes)}
LinRsvdMaskSize: Byte; {size of direct color reserved mask (linear modes)}
LinRsvdFieldPosition: Byte; {bit position of lsb of reserved mask (linear modes)}
MaxPixelClock: DWord; {maximum pixel clock (in Hz) for graphics mode}
Reserved4: array [1..189] of Byte; {remainder of ModeInfoBlock}
end;
TLogProcedure = procedure(const S: string);
TVBEModeMemoryModel =
(vmmmTextMode,
vmmmCGAGraphics,
vmmmHerculesGraphics,
vmmmPlanar,
vmmmPackedPixel,
vmmmNonChain4_256Color,
vmmmDirectColor,
vmmmYUV,
vmmmUnknownVESADefined,
vmmmUnknownOEMDefined);
TVBEFBWindow = class
private
FWindowID: Integer;
FRelocatable: Boolean;
FReadable: Boolean;
FWritable: Boolean;
FGranularity: Integer;
FSize: Integer;
FSegment: Word;
function GetSupported: Boolean;
public
constructor Create(AWindowID: Integer; AAttributes: Byte; AGranularity, ASize, ASegment: Word);
property WindowID: Integer read FWindowID;
property Relocatable: Boolean read FRelocatable;
property Readable: Boolean read FReadable;
property Writable: Boolean read FWritable;
property Granularity: Integer read FGranularity;
property Size: Integer read FSize;
property Segment: Word read FSegment;
property Supported: Boolean read GetSupported;
end;
TVBEMode = class
private
FVBEModeID: DWord;
FSupported: Boolean;
FSupportsTTY: Boolean;
FIsColor: Boolean;
FIsGraphics: Boolean;
FIsVGA: Boolean;
FSupportsWindowed: Boolean;
FSupportsLFB: Boolean;
FSupportsDoubleScan: Boolean;
FSupportsInterlaced: Boolean;
FSupportsTripleBuffering: Boolean;
FSupportsStereoscopicDisplay: Boolean;
FSupportsDualDisplayStartAddresses: Boolean;
FXResolution: Integer;
FYResolution: Integer;
FXCharSize: Integer;
FYCharSize: Integer;
FMemoryModel: TVBEModeMemoryModel;
FBitsPerPixel: Integer;
FNumberOfPlanes: Integer;
FNumberOfBanks: Integer;
FBankSize: Integer;
FWindowA: TVBEFBWindow;
FWindowB: TVBEFBWindow;
FReadWindow: TVBEFBWindow;
FWriteWindow: TVBEFBWindow;
FPhysBasePtr: DWord;
FWindowedBytesPerScanLine: Integer;
FWindowedNumberOfImagePages: Integer;
FWindowedRedMaskSize: Integer;
FWindowedRedFieldPosition: Integer;
FWindowedGreenMaskSize: Integer;
FWindowedGreenFieldPosition: Integer;
FWindowedBlueMaskSize: Integer;
FWindowedBlueFieldPosition: Integer;
FWindowedReservedMaskSize: Integer;
FWindowedReservedFieldPosition: Integer;
FLFBBytesPerScanLine: Integer;
FLFBNumberOfImagePages: Integer;
FLFBRedMaskSize: Integer;
FLFBRedFieldPosition: Integer;
FLFBGreenMaskSize: Integer;
FLFBGreenFieldPosition: Integer;
FLFBBlueMaskSize: Integer;
FLFBBlueFieldPosition: Integer;
FLFBReservedMaskSize: Integer;
FLFBReservedFieldPosition: Integer;
public
constructor Create(AModeID: DWord; const AModeInfoBlock: TVesaModeInfoBlock);
destructor Destroy; override;
property VBEModeID: DWord read FVBEModeID;
property Supported: Boolean read FSupported;
property SupportsTTY: Boolean read FSupportsTTY;
property IsColor: Boolean read FIsColor;
property IsGraphics: Boolean read FIsGraphics;
property IsVGA: Boolean read FIsVGA;
property SupportsWindowed: Boolean read FSupportsWindowed;
property SupportsLFB: Boolean read FSupportsLFB;
property SupportsDoubleScan: Boolean read FSupportsDoubleScan;
property SupportsInterlaced: Boolean read FSupportsInterlaced;
property SupportsTripleBuffering: Boolean read FSupportsTripleBuffering;
property SupportsStereoscopicDisplay: Boolean read FSupportsStereoscopicDisplay;
property SupportsDualDisplayStartAddresses: Boolean read FSupportsDualDisplayStartAddresses;
property XResolution: Integer read FXResolution;
property YResolution: Integer read FYResolution;
property XCharSize: Integer read FXCharSize;
property YCharSize: Integer read FYCharSize;
property MemoryModel: TVBEModeMemoryModel read FMemoryModel;
property BitsPerPixel: Integer read FBitsPerPixel;
property NumberOfPlanes: Integer read FNumberOfPlanes;
property NumberOfBanks: Integer read FNumberOfBanks;
property BankSize: Integer read FBankSize;
property WindowA: TVBEFBWindow read FWindowA;
property WindowB: TVBEFBWindow read FWindowB;
property ReadWindow: TVBEFBWindow read FReadWindow;
property WriteWindow: TVBEFBWindow read FWriteWindow;
property PhysBasePtr: DWord read FPhysBasePtr;
property WindowedBytesPerScanLine: Integer read FWindowedBytesPerScanLine;
property WindowedNumberOfImagePages: Integer read FWindowedNumberOfImagePages;
property WindowedRedMaskSize: Integer read FWindowedRedMaskSize;
property WindowedRedFieldPosition: Integer read FWindowedRedFieldPosition;
property WindowedGreenMaskSize: Integer read FWindowedGreenMaskSize;
property WindowedGreenFieldPosition: Integer read FWindowedGreenFieldPosition;
property WindowedBlueMaskSize: Integer read FWindowedBlueMaskSize;
property WindowedBlueFieldPosition: Integer read FWindowedBlueFieldPosition;
property WindowedReservedMaskSize: Integer read FWindowedReservedMaskSize;
property WindowedReservedFieldPosition: Integer read FWindowedReservedFieldPosition;
property LFBBytesPerScanLine: Integer read FLFBBytesPerScanLine;
property LFBNumberOfImagePages: Integer read FLFBNumberOfImagePages;
property LFBRedMaskSize: Integer read FLFBRedMaskSize;
property LFBRedFieldPosition: Integer read FLFBRedFieldPosition;
property LFBGreenMaskSize: Integer read FLFBGreenMaskSize;
property LFBGreenFieldPosition: Integer read FLFBGreenFieldPosition;
property LFBBlueMaskSize: Integer read FLFBBlueMaskSize;
property LFBBlueFieldPosition: Integer read FLFBBlueFieldPosition;
property LFBReservedMaskSize: Integer read FLFBReservedMaskSize;
property LFBReservedFieldPosition: Integer read FLFBReservedFieldPosition;
end;
{ PModeInfo = ^TModeInfo;
TModeInfo = record
ModeNumber: DWord;
VesaModeInfo: TVesaModeInfoBlock;
end;}
const
// TryLFBDefault = true;
TryDPMI508hDefault = true;
TryNearPtrDefault = false;
ScanModesManuallyDefault = false;
var
{ ModeInfo: PModeInfo;}
VBEModes: array of TVBEMode;
{ NrOfModes: Integer;}
VBEPresent: Boolean;
LFBUsed: Boolean;
LogProcedure: TLogProcedure = nil;
// TryLFB: Boolean = TryLFBDefault;
TryDPMI508h: Boolean = TryDPMI508hDefault;
TryNearPtr: Boolean = TryNearPtrDefault;
ScanModesManually: Boolean = ScanModesManuallyDefault;
EightBitDACEnabled: Boolean = true;
procedure InitVESA;
function SetVESAMode(M: Integer; AUseLFB: Boolean): Boolean;
procedure RestoreTextMode;
procedure WriteToVideoMemory(Src: Pointer; Dest: DWord; Size: DWord);
procedure SetPalette(Palette: Pointer; First, Num: Integer);
procedure GetPalette(Palette: Pointer; First, Num: Integer);
procedure SetDisplayStart(X, Y: Word; WaitRetrace: Boolean);
procedure WaitRetraceSinglePage;
function MakeMask(MaskSize, FieldPosition: Integer): DWord;
function LFBNearPtrAccessAvailable: Boolean;
function LFBNearPtrAccessPtr: Pointer;
implementation
uses
go32;
type
TVBEInfoBlock = packed record
{VBE 1.0+}
VBESignature: array [1..4] of Char; {'VESA'}
VBEVersion: Word;
OemStringPtr: DWord; {VbeFarPtr to OEM string}
Capabilities: DWord; {Capabilities of graphics controller}
VideoModePtr: DWord; {VbeFarPtr to VideoModeList}
{added for VBE 1.1+}
TotalMemory: Word; {Number of 64kb memory blocks}
{added for VBE 2.0+}
OemSoftwareRev: Word; {VBE implementation Software revision}
OemVendorNamePtr: DWord; {VbeFarPtr to Vendor Name string}
OemProductNamePtr: DWord; {VbeFarPtr to Product Name string}
OemProductRevPtr: DWord; {VbeFarPtr to Product Revision string}
Reserved: array [1..222] of Byte; {Reserved for VBE implementation scratch area}
OemData: array [1..256] of Char; {Data Area for OEM Strings}
end;
TVideoModeList = array of Word;
var
VBEInfoBlock: TVBEInfoBlock;
VideoModeList: TVideoModeList;
VideoMemory: DWord;
EightBitDACSupported: Boolean;
nonVGA: Boolean;
SnowyRAMDAC: Boolean;
StereoSignalingSupport: Boolean;
StereoSignalingVesaEVC: Boolean;
OEMString: string;
OEMVendorName: string;
OEMProductName: string;
OEMProductRev: string;
OEMSoftwareRev: Integer;
CurrentMode: TVBEMode = nil;
RealModePaletteSel: Word;
RealModePaletteSeg: Word;
SetPaletteHW: Boolean;
PaletteDACbits: Integer;
ReadWindow, WriteWindow: Integer;
ReadWindowStart, WriteWindowStart: Integer;
ReadWindowAddress, WriteWindowAddress: Integer;
WindowGranularity: DWord;
WindowSize, WindowSizeG: DWord;
DPMIPageSize: DWord;
LFBPhysicalAddress: DWord;
LFBBufferSize: DWord;
LFB0508AllocatedMemoryBlock: Pointer;
LFB0508MemoryBlockPadding: DWord;
LFB0508MappedVideoBufferStart: Pointer;
LFB0508NumberOfPagesMapped: Integer;
LFB0508Mapped: Boolean = false;
LFB0800LinearAddress: DWord;
LFB0800LinearAddressMapped: Boolean = false;
LFBSegmentSelector: Word = 0;
VESAInit: Boolean;
procedure Debugln(const S: string);
begin
if Assigned(LogProcedure) then
LogProcedure(S);
end;
procedure Debugln;
begin
Debugln('');
end;
function IntToStr(Value: Integer): string;
begin
System.Str(Value, Result);
end;
function IntToStr(Value: Int64): string;
begin
System.Str(Value, Result);
end;
function IntToStr(Value: QWord): string;
begin
System.Str(Value, Result);
end;
function BoolToStr(Value: Boolean): string;
begin
if Value then
Result := 'TRUE'
else
Result := 'FALSE';
end;
function CheckVBEStatus(AX: Word): Boolean;
begin
if AX = $004F then
begin
Result := true;
end
else
begin
Result := false;
Debugln('VBE returned error status (AX=$' + HexStr(AX, 4) + ')');
end;
end;
constructor TVBEFBWindow.Create(AWindowID: Integer; AAttributes: Byte; AGranularity, ASize, ASegment: Word);
begin
FWindowID := AWindowID;
FRelocatable := (AAttributes and 1) <> 0;
FReadable := (AAttributes and 2) <> 0;
FWritable := (AAttributes and 4) <> 0;
FGranularity := AGranularity;
FSize := ASize;
FSegment := ASegment;
end;
function TVBEFBWindow.GetSupported: Boolean;
begin
Result := (FReadable or FWritable) and ((FSegment <> 0) or FRelocatable);
end;
constructor TVBEMode.Create(AModeID: DWord; const AModeInfoBlock: TVesaModeInfoBlock);
begin
FVBEModeID := AModeID;
FSupported := (AModeInfoBlock.ModeAttributes and 1) <> 0;
FSupportsTTY := (AModeInfoBlock.ModeAttributes and 4) <> 0;
FIsColor := (AModeInfoBlock.ModeAttributes and 8) <> 0;
FIsGraphics := (AModeInfoBlock.ModeAttributes and 16) <> 0;
FIsVGA := (AModeInfoBlock.ModeAttributes and 32) = 0;
FSupportsWindowed := (AModeInfoBlock.ModeAttributes and 64) = 0;
FSupportsLFB := (AModeInfoBlock.ModeAttributes and 128) <> 0;
FSupportsDoubleScan := (AModeInfoBlock.ModeAttributes and 256) <> 0;
FSupportsInterlaced := (AModeInfoBlock.ModeAttributes and 512) <> 0;
FSupportsTripleBuffering := (AModeInfoBlock.ModeAttributes and 1024) <> 0;
FSupportsStereoscopicDisplay := (AModeInfoBlock.ModeAttributes and 2048) <> 0;
FSupportsDualDisplayStartAddresses := (AModeInfoBlock.ModeAttributes and 4096) <> 0;
if (AModeInfoBlock.ModeAttributes and 2) = 0 then
FSupported := false;
FXResolution := AModeInfoBlock.XResolution;
FYResolution := AModeInfoBlock.YResolution;
FXCharSize := AModeInfoBlock.XCharSize;
FYCharSize := AModeInfoBlock.YCharSize;
case AModeInfoBlock.MemoryModel of
0: FMemoryModel := vmmmTextMode;
1: FMemoryModel := vmmmCGAGraphics;
2: FMemoryModel := vmmmHerculesGraphics;
3: FMemoryModel := vmmmPlanar;
4: FMemoryModel := vmmmPackedPixel;
5: FMemoryModel := vmmmNonChain4_256Color;
6: FMemoryModel := vmmmDirectColor;
7: FMemoryModel := vmmmYUV;
8..15: FMemoryModel := vmmmUnknownVESADefined;
else
FMemoryModel := vmmmUnknownOEMDefined;
end;
FBitsPerPixel := AModeInfoBlock.BitsPerPixel;
FNumberOfPlanes := AModeInfoBlock.NumberOfPlanes;
FNumberOfBanks := AModeInfoBlock.NumberOfBanks;
FBankSize := AModeInfoBlock.BankSize;
if FSupportsWindowed then
begin
FWindowA := TVBEFBWindow.Create(0, AModeInfoBlock.WinAAttributes, AModeInfoBlock.WinGranularity, AModeInfoBlock.WinSize, AModeInfoBlock.WinASegment);
FWindowB := TVBEFBWindow.Create(1, AModeInfoBlock.WinBAttributes, AModeInfoBlock.WinGranularity, AModeInfoBlock.WinSize, AModeInfoBlock.WinBSegment);
FReadWindow := nil;
FWriteWindow := nil;
if FWindowA.Supported then
begin
if FWindowA.Readable then
FReadWindow := FWindowA;
if FWindowA.Writable then
FWriteWindow := FWindowA;
end;
if FWindowB.Supported then
begin
if FWindowB.Readable then
FReadWindow := FWindowB;
if FWindowB.Writable then
FWriteWindow := FWindowB;
end;
if (FReadWindow = nil) or (FWriteWindow = nil) then
FSupportsWindowed := false;
end;
if (not FSupportsWindowed) and (not FSupportsLFB) then
FSupported := false;
FPhysBasePtr := AModeInfoBlock.PhysBasePtr;
FWindowedBytesPerScanLine := AModeInfoBlock.BytesPerScanLine;
FWindowedNumberOfImagePages := AModeInfoBlock.BnkNumberOfImagePages;
FWindowedRedMaskSize := AModeInfoBlock.RedMaskSize;
FWindowedRedFieldPosition := AModeInfoBlock.RedFieldPosition;
FWindowedGreenMaskSize := AModeInfoBlock.GreenMaskSize;
FWindowedGreenFieldPosition := AModeInfoBlock.GreenFieldPosition;
FWindowedBlueMaskSize := AModeInfoBlock.BlueMaskSize;
FWindowedBlueFieldPosition := AModeInfoBlock.BlueFieldPosition;
FWindowedReservedMaskSize := AModeInfoBlock.RsvdMaskSize;
FWindowedReservedFieldPosition := AModeInfoBlock.RsvdFieldPosition;
FLFBBytesPerScanLine := AModeInfoBlock.LinBytesPerScanLine;
FLFBNumberOfImagePages := AModeInfoBlock.LinNumberOfImagePages;
FLFBRedMaskSize := AModeInfoBlock.LinRedMaskSize;
FLFBRedFieldPosition := AModeInfoBlock.LinRedFieldPosition;
FLFBGreenMaskSize := AModeInfoBlock.LinGreenMaskSize;
FLFBGreenFieldPosition := AModeInfoBlock.LinGreenFieldPosition;
FLFBBlueMaskSize := AModeInfoBlock.LinBlueMaskSize;
FLFBBlueFieldPosition := AModeInfoBlock.LinBlueFieldPosition;
FLFBReservedMaskSize := AModeInfoBlock.LinRsvdMaskSize;
FLFBReservedFieldPosition := AModeInfoBlock.LinRsvdFieldPosition;
end;
destructor TVBEMode.Destroy;
begin
FWindowA.Free;
FWindowB.Free;
inherited;
end;
procedure StandardMode(ModeNumber: DWord; var ModeInfo: TVesaModeInfoBlock);
const
StandardModes: array [$100..$10C, 1..7] of Integer = (
{(XResolution, YResolution, XCharSize, YCharSize, NumberOfPlanes, BitsPerPixel, MemoryModel),}
( 640, 400, 8, 16, 1, 8, 4), { 100 640x400x256 }
( 640, 480, 8, 16, 1, 8, 4), { 101 640x480x256 }
( 800, 600, 8, 16, 4, 4, 3), { 102 800x600x16 }
( 800, 600, 8, 16, 1, 8, 4), { 103 800x600x256 }
(1024, 768, 8, 16, 4, 4, 3), { 104 1024x768x16 }
(1024, 768, 8, 16, 1, 8, 4), { 105 1024x768x256 }
(1280, 1024, 8, 16, 4, 4, 3), { 106 1280x1024x16 }
(1280, 1024, 8, 16, 1, 8, 4), { 107 1280x1024x256 }
( 80, 60, 8, 16, 4, 4, 0), { 108 80x60t }
( 132, 25, 8, 16, 4, 4, 0), { 109 132x25t }
( 132, 43, 8, 16, 4, 4, 0), { 10A 132x43t }
( 132, 50, 8, 16, 4, 4, 0), { 10B 132x50t }
( 132, 60, 8, 16, 4, 4, 0)); { 10C 132x60t }
{
10D 320x200x32k
10E 320x200x64k
10F 320x200x16.8m
110 640x480x32k
111 640x480x64k
112 640x480x16.8m
113 800x600x32k
114 800x600x64k
115 800x600x16.8m
116 1024x768x32k
117 1024x768x64k
118 1024x768x16.8m
119 1280x1024x32k
11A 1280x1024x64k
11B 1280x1024x16.8m
}
begin
with ModeInfo do
begin
ModeAttributes := ModeAttributes or 2;
if ModeNumber = $6A then
ModeNumber := $102;
case ModeNumber of
$100..$10C: begin
XResolution := StandardModes[ModeNumber, 1];
YResolution := StandardModes[ModeNumber, 2];
XCharSize := StandardModes[ModeNumber, 3];
YCharSize := StandardModes[ModeNumber, 4];
NumberOfPlanes := StandardModes[ModeNumber, 5];
BitsPerPixel := StandardModes[ModeNumber, 6];
MemoryModel := StandardModes[ModeNumber, 7];
end;
{todo:10D..11B}
else
ModeAttributes := ModeAttributes and $FFFD;
end;
// NumberOfImagePages := 0;{...}
end;
end;
function bcd(q: Integer): Integer;
begin
q := q and $FF;
if ((q and $F) < 10) and ((q shr 4) < 10) then
bcd := (q and $F) + (q shr 4) * 10
else
bcd := q;
end;
procedure DisposeRealModePalette;
begin
if RealModePaletteSel = 0 then
exit;
global_dos_free(RealModePaletteSel);
RealModePaletteSel := 0;
RealModePaletteSeg := 0;
end;
procedure AllocateRealModePalette;
var
Addr: DWord;
begin
DisposeRealModePalette;
Addr := global_dos_alloc(256*4);
RealModePaletteSeg := Addr shr 16;
RealModePaletteSel := Addr and $FFFF;
end;
procedure SetPalette2(Palette: Pointer; Num: Integer); assembler; register;
asm
push es
cld
mov esi, Palette
mov ecx, Num
mov ax, fs
mov es, ax
movzx edi, word [RealModePaletteSeg]
shl edi, 4
mov edx, 0003F3F3Fh
@@1:
lodsd
shr eax, 2 {convert 8->6bit}
and eax, edx
stosd
dec ecx
jnz @@1
pop es
end;
procedure SetPalette3(Palette: Pointer; Num: Integer); assembler; register;
asm
push es
cld
mov esi, Palette
mov ecx, Num
mov ax, fs
mov es, ax
movzx edi, word [RealModePaletteSeg]
shl edi, 4
mov edx, 0007F7F7Fh
@@1:
lodsd
shr eax, 1 {convert 8->7bit}
and eax, edx
stosd
dec ecx
jnz @@1
pop es
end;
procedure SetPaletteHW6(Palette: Pointer; First, Num: Integer);
var
p: PDWord;
c: DWord;
begin
p := PDWord(Palette);
outportb($3C8, First);
while Num > 0 do
begin
c := (p^ shr 2) and $3F3F3F;
outportb($3C9, Byte(c shr 16));
outportb($3C9, Byte(c shr 8));
outportb($3C9, Byte(c));
Inc(p);
Dec(Num);
end;
end;
procedure SetPaletteHW7(Palette: Pointer; First, Num: Integer);
var
p: PDWord;
c: DWord;
begin
p := PDWord(Palette);
outportb($3C8, First);
while Num > 0 do
begin
c := (p^ shr 1) and $7F7F7F;
outportb($3C9, Byte(c shr 16));
outportb($3C9, Byte(c shr 8));
outportb($3C9, Byte(c));
Inc(p);
Dec(Num);
end;
end;
procedure SetPaletteHW8(Palette: Pointer; First, Num: Integer);
var
p: PDWord;
begin
p := PDWord(Palette);
outportb($3C8, First);
while Num > 0 do
begin
outportb($3C9, Byte(p^ shr 16));
outportb($3C9, Byte(p^ shr 8));
outportb($3C9, Byte(p^));
Inc(p);
Dec(Num);
end;
end;
procedure SetPalette(Palette: Pointer; First, Num: Integer);
var
RealRegs: TRealRegs;
begin
if SetPaletteHW then
begin
case PaletteDACbits of
8: SetPaletteHW8(Palette, First, Num);
7: SetPaletteHW7(Palette, First, Num);
6: SetPaletteHW6(Palette, First, Num);
end;
end
else
begin
if PaletteDACbits = 8 then
dosmemput(RealModePaletteSeg, 0, Palette^, Num * 4) {8bits}
else
if PaletteDACbits = 7 then
SetPalette3(Palette, Num) {7bits}
else
SetPalette2(Palette, Num); {6bits}
RealRegs.ax := $4F09;
RealRegs.bl := 0;
RealRegs.cx := Num;
RealRegs.dx := First;
RealRegs.es := RealModePaletteSeg;
RealRegs.di := 0;
realintr($10, RealRegs);
end;
end;
procedure GetPalette(Palette: Pointer; First, Num: Integer);
var
RealRegs: TRealRegs;
begin
RealRegs.ax := $4F09;
RealRegs.bl := 1;
RealRegs.cx := Num;
RealRegs.dx := First;
RealRegs.es := RealModePaletteSeg;
RealRegs.di := 0;
realintr($10, RealRegs);
{...}
end;
procedure SwitchTo8bitDAC;
var
RealRegs: TRealRegs;
begin
Debugln('Trying to switch to 8-bit DAC');
RealRegs.ax := $4F08;
RealRegs.bl := 0;
RealRegs.bh := 8;
realintr($10, RealRegs);
if not CheckVBEStatus(RealRegs.ax) then
begin
Debugln('Switching to 8-bit DAC failed');
exit;
end;
PaletteDACbits := RealRegs.bh;
Debugln('DAC switched to ' + IntToStr(PaletteDACbits) + ' bits');
if PaletteDACbits < 6 then
begin
Debugln('DAC switched to less than 6 bits?! All VBE video cards should support at least 6 bits DAC width!!!');
Debugln('We''re assuming that the VBE BIOS is buggy and that we got a bogus value and the DAC is actually in 6-bits mode!!!');
Debugln('If it looks wrong, try the ''no8bitdac'' option in the ptcpas.cfg file.');
PaletteDACbits := 6;
end;
end;
function MakeMask(MaskSize, FieldPosition: Integer): DWord;
var
Mask: DWord;
I: Integer;
begin
Mask := 1 shl FieldPosition;
for I := 2 to MaskSize do
Mask := Mask or (Mask shl 1);
MakeMask := Mask;
end;
function GetRMString(SegOfs: DWord): string;
var
S: string;
C: Char;
Seg, Ofs: Word;
begin
if SegOfs = 0 then
begin
GetRMString := '';
exit;
end;
S := '';
Ofs := SegOfs and $FFFF;
Seg := SegOfs shr 16;
repeat
dosmemget(Seg, Ofs, C, 1);
if C <> #0 then
begin
S := S + C;
if Ofs = $FFFF then
begin
Ofs := 0;
Inc(Seg, $1000);
end
else
Inc(Ofs);
end;
until C = #0;
Result := S;
end;
procedure SetWriteWindowStart(WinPos: DWord);
var
RealRegs: TRealRegs;
begin
RealRegs.ax := $4F05;
RealRegs.bx := WriteWindow;
RealRegs.dx := WinPos;
realintr($10, RealRegs);
end;
procedure VGAWaitRetrace;
begin
while (inportb($3DA) and 8) <> 0 do;
while (inportb($3DA) and 8) = 0 do;
end;
{ (X <> 0) or (Y <> 0) requires VBE 1.1+ }
procedure SetDisplayStart(X, Y: Word; WaitRetrace: Boolean);
var
RealRegs: TRealRegs;
begin
RealRegs.ax := $4F07;
RealRegs.bx := $0000;
if WaitRetrace then
if VBEInfoBlock.VBEVersion >= $0200 then
RealRegs.bx := $0080
else
begin
VGAWaitRetrace;
if VBEInfoBlock.VBEVersion < $0101 then
exit; { VBE 1.0 does not support function 07h - set display start }
end;
RealRegs.cx := X;
RealRegs.dx := Y;
realintr($10, RealRegs);
end;
procedure WaitRetraceSinglePage;
var
RealRegs: TRealRegs;
begin
if (VBEInfoBlock.VBEVersion >= $0200) and (not CurrentMode.IsVGA) then
begin
RealRegs.ax := $4F07;
RealRegs.bx := $0080;
RealRegs.cx := 0;
RealRegs.dx := 0;
realintr($10, RealRegs);
end
else
VGAWaitRetrace;
end;
procedure WriteToVideoMemoryLFB(Src: Pointer; Dest: DWord; Size: DWord);
begin
asm
push es
mov esi, Src
mov edi, Dest
mov ax, LFBSegmentSelector
mov es, ax
mov ecx, Size
shr ecx, 2
cld
rep movsd
mov ecx, Size
and ecx, 3
jz @@1
rep movsb
@@1:
pop es
end ['EAX', 'ECX', 'ESI', 'EDI'];
end;
procedure WriteToVideoMemory(Src: Pointer; Dest: DWord; Size: DWord);
var
WW: Integer;
ToDo: Integer;
begin
if LFBUsed then
begin
WriteToVideoMemoryLFB(Src, Dest, Size);
exit;
end;
WW := Dest div WindowGranularity;
Dest := Dest mod WindowGranularity;
{ Writeln(WindowSize);}
while Size > 0 do
begin
{ Write(WW, ' ');}
SetWriteWindowStart(WW);
ToDo := WindowSize - Dest;
if Size < ToDo then
ToDo := Size;
asm
push es
mov esi, Src
mov edi, Dest
add edi, WriteWindowAddress
mov ax, fs
mov es, ax
mov ecx, ToDo
shr ecx, 2
cld
rep movsd
mov ecx, ToDo
and ecx, 3
jz @@1
rep movsb
@@1:
pop es
end ['EAX', 'ECX', 'ESI', 'EDI'];
Dest := 0;
Inc(WW, WindowSizeG);
{ Inc(WW);}
Inc(Src, ToDo);
Dec(Size, ToDo);
end;
end;
function WinAttrib(q: Integer): string;
begin
if (q and 1) <> 0 then
Result := 'supported'
else
Result := 'not_supported';
if (q and 2) <> 0 then
Result := Result + ' readable';
if (q and 4) <> 0 then
Result := Result + ' writeable';
end;
function ModeAttrib(AModeAttributes: Integer): string;
begin
if (AModeAttributes and 1) <> 0 then
Result := 'supported'
else
Result := 'not_supported';
if (AModeAttributes and 2) <> 0 then
else
Result := Result + ' reserved_is_zero(noresolutioninfo_for_vbe1.1-)';
if (AModeAttributes and 4) <> 0 then
Result := Result + ' TTY'
else
Result := Result + ' noTTY';
if (AModeAttributes and 8) <> 0 then
Result := Result + ' color'
else
Result := Result + ' monochrome';
if (AModeAttributes and 16) <> 0 then
Result := Result + ' graph'
else
Result := Result + ' text';
if (AModeAttributes and 32) <> 0 then
Result := Result + ' nonVGA'
else
Result := Result + ' VGA';
if (AModeAttributes and 64) <> 0 then
Result := Result + ' noWINDOWED'
else
Result := Result + ' WINDOWED';
if (AModeAttributes and 128) <> 0 then
Result := Result + ' LFB'
else
Result := Result + ' noLFB';
if (AModeAttributes and 256) <> 0 then
Result := Result + ' DoubleScanMode_is_available';
if (AModeAttributes and 512) <> 0 then
Result := Result + ' InterlacedMode_is_available';
if (AModeAttributes and 1024) <> 0 then
Result := Result + ' TripleBuffering';
if (AModeAttributes and 2048) <> 0 then
Result := Result + ' StereoscopicDisplaySupport';
if (AModeAttributes and 4096) <> 0 then
Result := Result + ' DualDisplayStartAddressSupport';
end;
function MemoryModelStr(AMemoryModel: Integer): string;
begin
case AMemoryModel of
0: Result := 'Text mode';
1: Result := 'CGA graphics';
2: Result := 'Hercules graphics';
3: Result := 'Planar';
4: Result := 'Packed pixel';
5: Result := 'Non-chain 4, 256 color';
6: Result := 'Direct Color';
7: Result := 'YUV';
8..15: Write('Reserved, to be defined by VESA');
else
Result := 'to be defined by OEM';
end;
Result := Result + '/' + IntToStr(AMemoryModel);
end;
function DirectColorModeInfoStr(ADirectColorModeInfo: Integer): string;
begin
if (ADirectColorModeInfo and 1) <> 0 then
Result := 'Color_ramp_is_programmable'
else
Result := 'Color_ramp_is_fixed';
if (ADirectColorModeInfo and 2) <> 0 then
Result := Result + ' Rsvd_bits_usable_by_app'
else
Result := Result + ' Rsvd_bits_reserved';
end;
procedure FreeModes;
var
I: Integer;
begin
CurrentMode := nil;
for I := Low(VBEModes) to High(VBEModes) do
{ FreeAndNil(VBEModes[I])}
VBEModes[I].Free;
SetLength(VBEModes, 0);
end;
procedure GetModes;
var
Addr: DWord;
AddrSeg, AddrSel: Word;
procedure LogModeInfo(ModeNumber: Integer; const VesaModeInfo: TVesaModeInfoBlock);
begin
Debugln(' ModeNumber: $' + HexStr(ModeNumber, 4));
Debugln(' ModeAttributes: ' + ModeAttrib(VesaModeInfo.ModeAttributes));
Debugln(' WinAAttributes: ' + WinAttrib(VesaModeInfo.WinAAttributes));
Debugln(' WinBAttributes: ' + WinAttrib(VesaModeInfo.WinBAttributes));
Debugln(' WinGranularity: ' + IntToStr(VesaModeInfo.WinGranularity) + ' KB');
Debugln(' WinSize: ' + IntToStr(VesaModeInfo.WinSize) + ' KB');
Debugln(' WinASegment: $' + HexStr(VesaModeInfo.WinASegment, 4));
Debugln(' WinBSegment: $' + HexStr(VesaModeInfo.WinBSegment, 4));
Debugln(' WinFuncPtr: ' + HexStr(VesaModeInfo.WinFuncPtr shr 16, 4) + ':' + HexStr(VesaModeInfo.WinFuncPtr and $FFFF, 4));
Debugln(' BytesPerScanLine: ' + IntToStr(VesaModeInfo.BytesPerScanLine));
Debugln('vbe1.2+');
Debugln(' XResolution: ' + IntToStr(VesaModeInfo.XResolution));
Debugln(' YResolution: ' + IntToStr(VesaModeInfo.YResolution));
Debugln(' XCharSize: ' + IntToStr(VesaModeInfo.XCharSize));
Debugln(' YCharSize: ' + IntToStr(VesaModeInfo.YCharSize));
Debugln(' NumberOfPlanes: ' + IntToStr(VesaModeInfo.NumberOfPlanes));
Debugln(' BitsPerPixel: ' + IntToStr(VesaModeInfo.BitsPerPixel));
Debugln(' NumberOfBanks: ' + IntToStr(VesaModeInfo.NumberOfBanks));
Debugln(' MemoryModel: ' + MemoryModelStr(VesaModeInfo.MemoryModel));
Debugln(' BankSize: ' + IntToStr(VesaModeInfo.BankSize) + ' KB');
Debugln(' NumberOfImagePages: ' + IntToStr(VesaModeInfo.NumberOfImagePages));
Debugln(' Reserved(=1): ' + IntToStr(VesaModeInfo.Reserved));
Debugln(' RedMaskSize: ' + IntToStr(VesaModeInfo.RedMaskSize));
Debugln(' RedFieldPosition: ' + IntToStr(VesaModeInfo.RedFieldPosition));
Debugln(' GreenMaskSize: ' + IntToStr(VesaModeInfo.GreenMaskSize));
Debugln(' GreenFieldPosition: ' + IntToStr(VesaModeInfo.GreenFieldPosition));
Debugln(' BlueMaskSize: ' + IntToStr(VesaModeInfo.BlueMaskSize));
Debugln(' BlueFieldPosition: ' + IntToStr(VesaModeInfo.BlueFieldPosition));
Debugln(' RsvdMaskSize: ' + IntToStr(VesaModeInfo.RsvdMaskSize));
Debugln(' RsvdFieldPosition: ' + IntToStr(VesaModeInfo.RsvdFieldPosition));
Debugln(' DirectColorModeInfo: ' + DirectColorModeInfoStr(VesaModeInfo.DirectColorModeInfo));
Debugln('vbe2.0+');
Debugln(' PhysBasePtr: $' + HexStr(VesaModeInfo.PhysBasePtr, 8));
Debugln(' Reserved2(=0): ' + IntToStr(VesaModeInfo.Reserved2));
Debugln(' Reserved3(=0): ' + IntToStr(VesaModeInfo.Reserved3));
Debugln('vbe3.0+');
Debugln(' LinBytesPerScanLine: ' + IntToStr(VesaModeInfo.LinBytesPerScanLine));
Debugln('BnkNumberOfImagePages: ' + IntToStr(VesaModeInfo.BnkNumberOfImagePages));
Debugln('LinNumberOfImagePages: ' + IntToStr(VesaModeInfo.LinNumberOfImagePages));
Debugln(' LinRedMaskSize: ' + IntToStr(VesaModeInfo.LinRedMaskSize));
Debugln(' LinRedFieldPosition: ' + IntToStr(VesaModeInfo.LinRedFieldPosition));
Debugln(' LinGreenMaskSize: ' + IntToStr(VesaModeInfo.LinGreenMaskSize));
Debugln('LinGreenFieldPosition: ' + IntToStr(VesaModeInfo.LinGreenFieldPosition));
Debugln(' LinBlueMaskSize: ' + IntToStr(VesaModeInfo.LinBlueMaskSize));
Debugln(' LinBlueFieldPosition: ' + IntToStr(VesaModeInfo.LinBlueFieldPosition));
Debugln(' LinRsvdMaskSize: ' + IntToStr(VesaModeInfo.LinRsvdMaskSize));
Debugln(' LinRsvdFieldPosition: ' + IntToStr(VesaModeInfo.LinRsvdFieldPosition));
Debugln(' MaxPixelClock: ' + IntToStr(VesaModeInfo.MaxPixelClock));
Debugln;
{ Write(VesaModeInfo.XResolution, 'x', VesaModeInfo.YResolution, 'x',
VesaModeInfo.BitsPerPixel, '-', VesaModeInfo.MemoryModel,
'R', VesaModeInfo.RedMaskSize, ':', VesaModeInfo.RedFieldPosition,
'G', VesaModeInfo.GreenMaskSize, ':', VesaModeInfo.GreenFieldPosition,
'B', VesaModeInfo.BlueMaskSize, ':', VesaModeInfo.BlueFieldPosition,
'A', VesaModeInfo.RsvdMaskSize, ':', VesaModeInfo.RsvdFieldPosition, ' ');}
end;
procedure FillModeMissingData(ModeNumber: Integer; var VesaModeInfo: TVesaModeInfoBlock);
begin
if (VesaModeInfo.ModeAttributes and 1) <> 0 then
begin
if (VesaModeInfo.ModeAttributes and 2) = 0 then
begin
if VBEInfoBlock.VBEVersion < $0102 then
StandardMode(ModeNumber, VesaModeInfo);
end;
if VBEInfoBlock.VBEVersion < $0300 then
begin
VesaModeInfo.LinBytesPerScanLine := VesaModeInfo.BytesPerScanLine;
VesaModeInfo.BnkNumberOfImagePages := VesaModeInfo.NumberOfImagePages;
VesaModeInfo.LinNumberOfImagePages := VesaModeInfo.NumberOfImagePages;
VesaModeInfo.LinRedMaskSize := VesaModeInfo.RedMaskSize;
VesaModeInfo.LinRedFieldPosition := VesaModeInfo.RedFieldPosition;
VesaModeInfo.LinGreenMaskSize := VesaModeInfo.GreenMaskSize;
VesaModeInfo.LinGreenFieldPosition := VesaModeInfo.GreenFieldPosition;
VesaModeInfo.LinBlueMaskSize := VesaModeInfo.BlueMaskSize;
VesaModeInfo.LinBlueFieldPosition := VesaModeInfo.BlueFieldPosition;
VesaModeInfo.LinRsvdMaskSize := VesaModeInfo.RsvdMaskSize;
VesaModeInfo.LinRsvdFieldPosition := VesaModeInfo.RsvdFieldPosition;
end;
end;
end;
procedure TryAddMode(ModeNumber: Word);
var
RealRegs: TRealRegs;
VesaModeInfo: TVesaModeInfoBlock;
VBEMode: TVBEMode;
begin
FillChar(VesaModeInfo, SizeOf(VesaModeInfo), 0);
dosmemput(AddrSeg, 0, VesaModeInfo, SizeOf(VesaModeInfo));
RealRegs.ax := $4F01; {return VBE mode information}
RealRegs.cx := ModeNumber;
RealRegs.es := AddrSeg;
RealRegs.di := 0;
realintr($10, RealRegs);
dosmemget(AddrSeg, 0, VesaModeInfo, SizeOf(VesaModeInfo));
if ((VesaModeInfo.ModeAttributes and 1) <> 0) or
(VesaModeInfo.BytesPerScanLine <> 0) then
begin
LogModeInfo(ModeNumber, VesaModeInfo);
end;
FillModeMissingData(ModeNumber, VesaModeInfo);
VBEMode := TVBEMode.Create(ModeNumber, VesaModeInfo);
try
if VBEMode.Supported then
begin
SetLength(VBEModes, Length(VBEModes) + 1);
VBEModes[High(VBEModes)] := VBEMode;
VBEMode := nil;
end;
finally
VBEMode.Free;
end;
end;
var
I: Integer;
ModeNumber: Integer;
ScanStart, Scanend: Integer;
begin
FreeModes;
Addr := global_dos_alloc(512);
AddrSeg := Addr shr 16;
AddrSel := Addr and $FFFF;
try
if ScanModesManually then
begin
ScanStart := 0;
{ Scanend := $7FFF;} {VBE 1.0+ ??}
{ Scanend := $3FFF;} {VBE 1.2+ ??}
// Scanend := $7FF; {VBE 3.0+}
Scanend := $1FF; {VBE 3.0+}
Debugln('scanning modes $' + HexStr(ScanStart, 4) + '..$' + HexStr(Scanend, 4));
for ModeNumber := ScanStart to Scanend do
begin
TryAddMode(ModeNumber);
end;
end
else
begin
Debugln('Using the mode list, returned in the VBEInfoBlock');
for I := Low(VideoModeList) to High(VideoModeList) do
begin
ModeNumber := VideoModeList[I];
TryAddMode(ModeNumber);
end;
end;
finally
global_dos_free(AddrSel);
end;
end;
procedure GetVBEInfo;
function GetModeList: TVideoModeList;
var
ModeListAddr: DWord;
NumberOfModes: Integer;
I: Integer;
begin
NumberOfModes := 0;
ModeListAddr := (VBEInfoBlock.VideoModePtr shr 16) * 16 + (VBEInfoBlock.VideoModePtr and $FFFF);
while MemW[ModeListAddr] <> $FFFF do
begin
Inc(NumberOfModes);
Inc(ModeListAddr, 2);
end;
SetLength(Result, NumberOfModes);
I := 0;
ModeListAddr := (VBEInfoBlock.VideoModePtr shr 16) * 16 + (VBEInfoBlock.VideoModePtr and $FFFF);
while MemW[ModeListAddr] <> $FFFF do
begin
Result[I] := MemW[ModeListAddr];
Inc(I);
Inc(ModeListAddr, 2);
end;
end;
var
Addr: DWord;
AddrSeg: Word;
AddrSel: Word;
RealRegs: TRealRegs;
begin
Addr := global_dos_alloc(512);
try
AddrSeg := Addr shr 16;
AddrSel := Addr and $FFFF;
VBEInfoBlock.VBESignature := 'VBE2';
dosmemput(AddrSeg, 0, VBEInfoBlock, 4);
RealRegs.ax := $4F00;
RealRegs.es := AddrSeg;
RealRegs.di := 0;
realintr($10, RealRegs);
VBEPresent := CheckVBEStatus(RealRegs.ax);
if VBEPresent then
begin
dosmemget(AddrSeg, 0, VBEInfoBlock, SizeOf(VBEInfoBlock));
VBEPresent := VBEInfoBlock.VBESignature = 'VESA';
if not VBEPresent then
Debugln('VBEInfoBlock returned no ''VESA'' VBESignature. Assuming VBE is not supported.');
end;
if VBEPresent then
begin
VideoMemory := VBEInfoBlock.TotalMemory * 64;
EightBitDACSupported := (VBEInfoBlock.Capabilities and 1) <> 0;
nonVGA := (VBEInfoBlock.Capabilities and 2) <> 0;
SnowyRAMDAC := (VBEInfoBlock.Capabilities and 4) <> 0;
StereoSignalingSupport := (VBEInfoBlock.Capabilities and 8) <> 0;
StereoSignalingVesaEVC := (VBEInfoBlock.Capabilities and 16) <> 0;
OEMString := GetRMString(VBEInfoBlock.OemStringPtr);
if VBEInfoBlock.VBEVersion >= $0200 then
begin
OEMVendorName := GetRMString(VBEInfoBlock.OemVendorNamePtr);
OEMProductName := GetRMString(VBEInfoBlock.OemProductNamePtr);
OEMProductRev := GetRMString(VBEInfoBlock.OemProductRevPtr);
OEMSoftwareRev := VBEInfoBlock.OemSoftwareRev;
end
else
begin
OEMVendorName := '';
OEMProductName := '';
OEMProductRev := '';
OEMSoftwareRev := -1;
end;
Debugln('VBEVersion: ' + IntToStr(bcd(VBEInfoBlock.VBEVersion shr 8)) + '.' + IntToStr(bcd(VBEInfoBlock.VBEVersion and $FF)));
Debugln('VideoMemory: ' + IntToStr(VideoMemory) + ' KB');
Debugln('VideoModePtr: ' + HexStr(VBEInfoBlock.VideoModePtr shr 16, 4) + ':' + HexStr(VBEInfoBlock.VideoModePtr and $FFFF, 4));
Debugln('EightBitDACSupported: ' + BoolToStr(EightBitDACSupported));
Debugln('nonVGA: ' + BoolToStr(nonVGA));
Debugln('SnowyRAMDAC: ' + BoolToStr(SnowyRAMDAC));
Debugln('StereoSignalingSupport: ' + BoolToStr(StereoSignalingSupport));
if StereoSignalingSupport then
if StereoSignalingVesaEVC then
Debugln('Stereo signaling supported via VESA EVC connector')
else
Debugln('Stereo signaling supported via external VESA stereo connector');
if OEMString <> '' then
Debugln('OEMString: ' + OEMString);
if OEMVendorName <> '' then
Debugln('OEMVendorName: ' + OEMVendorName);
if OEMProductName <> '' then
Debugln('OEMProductName: ' + OEMProductName);
if OEMProductRev <> '' then
Debugln('OEMProductRev: ' + OEMProductRev);
if OEMSoftwareRev <> -1 then
Debugln('OEMSoftwareRev: ' + IntToStr(bcd(OEMSoftwareRev shr 8)) + '.' + IntToStr(bcd(OEMSoftwareRev and $FF)));
VideoModeList := GetModeList;
{Write('VideoModeList:');
tmp := (VBEInfoBlock.VideoModePtr shr 16) * 16 + (VBEInfoBlock.VideoModePtr and $FFFF);
while MemW[tmp] <> $FFFF do
begin
Write(' $', HexStr(MemW[tmp], 4));
Inc(tmp, 2);
end;
Writeln;}
Debugln;
end;
finally
global_dos_free(AddrSel);
end;
end;
var
__crt0_startup_flags: Byte; external name '__crt0_startup_flags';
___djgpp_base_address: DWord; external name '___djgpp_base_address';
___djgpp_selector_limit: DWord; external name '___djgpp_selector_limit';
___v2prt0_ds_alias: Word; external name '___v2prt0_ds_alias';
___djgpp_memory_handle_list: DWord; external name '___djgpp_memory_handle_list';
{ LFB0508AllocatedMemoryBlock: Pointer;
LFB0508MappedVideoBufferStart: Pointer;
LFB0508NumberOfPagesMapped: Integer;
LFB0508Mapped: Boolean;}
function MapLFBToLinearSpace0508(PhysicalAddress, Size: DWord): Boolean;
var
LinearAddress: DWord;
PhysicalAddressLeftPadding, PhysicalAddressRightPadding: DWord;
PaddedSize: DWord;
MapSuccess: Boolean;
MappedPageAttribute: Word;
begin
Debugln('Trying to map LFB, using DPMI function 0508h. Physical addr=$' + HexStr(PhysicalAddress, 8) + '; Size=$' + HexStr(Size, 8));
{align physical buffer to page boundaries...}
PhysicalAddressLeftPadding := PhysicalAddress mod DPMIPageSize;
PhysicalAddressRightPadding := (PhysicalAddress + Size) mod DPMIPageSize;
if PhysicalAddressRightPadding <> 0 then
PhysicalAddressRightPadding := DPMIPageSize - PhysicalAddressRightPadding;
Debugln('PhysicalAddressLeftPadding = ' + IntToStr(PhysicalAddressLeftPadding));
Debugln('PhysicalAddressRightPadding = ' + IntToStr(PhysicalAddressRightPadding));
PaddedSize := Size + PhysicalAddressLeftPadding + PhysicalAddressRightPadding;
Debugln('PaddedSize = ' + IntToStr(PaddedSize));
LFB0508AllocatedMemoryBlock := GetMem(PaddedSize + DPMIPageSize - 1);
LFB0508MemoryBlockPadding := (PtrUInt(LFB0508AllocatedMemoryBlock) + ___djgpp_base_address) mod DPMIPageSize;
if LFB0508MemoryBlockPadding <> 0 then
LFB0508MemoryBlockPadding := DPMIPageSize - LFB0508MemoryBlockPadding;
LFB0508NumberOfPagesMapped := PaddedSize div DPMIPageSize;
// Write('Before map...'); Readln;
MapSuccess := map_device_in_memory_block(___djgpp_memory_handle_list, PtrUInt(LFB0508AllocatedMemoryBlock) + LFB0508MemoryBlockPadding, LFB0508NumberOfPagesMapped, PhysicalAddress - PhysicalAddressLeftPadding);
if (not MapSuccess) or (int31error <> 0) then
begin
Debugln('DPMI error $' + HexStr(int31error, 4));
Result := false;
FreeMem(LFB0508AllocatedMemoryBlock);
LFB0508AllocatedMemoryBlock := nil;
exit;
end;
Debugln('DPMI function 0508h returned success!');
Debugln('Checking page attributes, to see if it really succeeded. (shitty NTVDM reports success, even though it does not support DPMI 0508h, so we need this extra check)');
MappedPageAttribute := $FFFF;
MapSuccess := get_page_attributes(___djgpp_memory_handle_list, PtrUInt(LFB0508AllocatedMemoryBlock) + LFB0508MemoryBlockPadding, 1, @MappedPageAttribute);
if (not MapSuccess) or (int31error <> 0) then
begin
Debugln('DPMI error $' + HexStr(int31error, 4));
Result := false;
FreeMem(LFB0508AllocatedMemoryBlock);
LFB0508AllocatedMemoryBlock := nil;
exit;
end;
Debugln('Page attribute = %' + BinStr(MappedPageAttribute, 16));
if (MappedPageAttribute and %111) <> 2 then
begin
Debugln('Page is not mapped!!! Probably a buggy NTVDM host.');
Result := false;
FreeMem(LFB0508AllocatedMemoryBlock);
LFB0508AllocatedMemoryBlock := nil;
exit;
end;
LFB0508MappedVideoBufferStart := LFB0508AllocatedMemoryBlock + LFB0508MemoryBlockPadding + PhysicalAddressLeftPadding;
LFBPhysicalAddress := PhysicalAddress;
LFBBufferSize := Size;
LFB0508Mapped := true;
Result := true;
end;
function FreeLFBMapping0508: Boolean;
var
SetPageAttributes: PWord;
UnMapSuccess: Boolean;
begin
if not LFB0508Mapped then
exit;
Debugln('Freeing the 0508h LFB mapping...');
SetPageAttributes := GetMem(LFB0508NumberOfPagesMapped * SizeOf(Word));
FillWord(SetPageAttributes^, LFB0508NumberOfPagesMapped, %01001);
UnMapSuccess := set_page_attributes(___djgpp_memory_handle_list, PtrUInt(LFB0508AllocatedMemoryBlock) + LFB0508MemoryBlockPadding, LFB0508NumberOfPagesMapped, SetPageAttributes);
FreeMem(SetPageAttributes);
if (not UnMapSuccess) or (int31error <> 0) then
begin
Debugln('DPMI error $' + HexStr(int31error, 4));
Result := false;
exit;
end;
Debugln('Mapped memory changed back to committed. Now freeing the allocated memory block from the pascal heap.');
FreeMem(LFB0508AllocatedMemoryBlock);
LFB0508Mapped := false;
Result := true;
Debugln('LFB 0508h mapping freed.');
end;
function MapLFBToLinearSpace0800(PhysicalAddress, Size: DWord): Boolean;
var
LinearAddress: DWord;
begin
Debugln('Trying to map LFB to linear address space. Physical addr=$' + HexStr(PhysicalAddress, 8) + '; Size=$' + HexStr(Size, 8));
LinearAddress := get_linear_addr(PhysicalAddress, VideoMemory * 1024);
if int31error <> 0 then
begin
Debugln('DPMI error $' + HexStr(int31error, 4));
Result := false;
exit;
end;
Debugln('Mapped successfully at linear address $' + HexStr(LinearAddress, 8));
LFBPhysicalAddress := PhysicalAddress;
LFBBufferSize := Size;
LFB0800LinearAddress := LinearAddress;
LFB0800LinearAddressMapped := true;
Result := true;
end;
function FreeLFBMapping0800: Boolean;
begin
if not LFB0800LinearAddressMapped then
exit;
Debugln('Freeing the LFB mapping in linear address space.');
free_linear_addr_mapping(LFB0800LinearAddress);
if int31error <> 0 then
begin
Debugln('DPMI error $' + HexStr(int31error, 4));
Debugln('Ignoring the error, as this function exists only in the DPMI 1.0 specification, and most DPMI hosts are 0.9');
Debugln('(well, at least we tried to be nice and called it)');
end;
LFB0800LinearAddressMapped := false;
LFB0800LinearAddress := 0;
Debugln('LFB mapping freed.');
Result := true;
end;
function NearPtrEnabled: Boolean;
const
_CRT0_FLAG_NEARPTR = $80;
begin
Result := (__crt0_startup_flags and _CRT0_FLAG_NEARPTR) <> 0;
end;
function EnableNearPtr: Boolean;
const
_CRT0_FLAG_NEARPTR = $80;
var
CurrentDSLimit: DWord;
begin
Debugln('Trying to enable nearptr (aka "Fat DS") mode...');
if NearPtrEnabled then
begin
Debugln('Already enabled... nothing to do...');
Result := true;
exit;
end;
CurrentDSLimit := get_segment_limit(get_ds);
Debugln('___djgpp_base_address=$' + HexStr(___djgpp_base_address, 8));
Debugln('___djgpp_selector_limit=$' + HexStr(___djgpp_selector_limit, 8));
Debugln('Current CS base=$' + HexStr(get_segment_base_address(get_cs), 8));
Debugln('Current DS base=$' + HexStr(get_segment_base_address(get_ds), 8));
Debugln('Current CS limit=$' + HexStr(get_segment_limit(get_cs), 8));
Debugln('Current DS limit=$' + HexStr(CurrentDSLimit, 8));
Debugln('__crt0_startup_flags=$' + HexStr(__crt0_startup_flags, 2));
Debugln('Trying to set DS limit to $FFFFFFFF...');
set_segment_limit(get_ds, $FFFFFFFF);
if int31error <> 0 then
begin
Debugln('DPMI error $' + HexStr(int31error, 4));
Result := false;
exit;
end;
CurrentDSLimit := get_segment_limit(get_ds);
Debugln('___djgpp_base_address=$' + HexStr(___djgpp_base_address, 8));
Debugln('___djgpp_selector_limit=$' + HexStr(___djgpp_selector_limit, 8));
Debugln('Current CS base=$' + HexStr(get_segment_base_address(get_cs), 8));
Debugln('Current DS base=$' + HexStr(get_segment_base_address(get_ds), 8));
Debugln('Current CS limit=$' + HexStr(get_segment_limit(get_cs), 8));
Debugln('Current DS limit=$' + HexStr(CurrentDSLimit, 8));
Debugln('__crt0_startup_flags=$' + HexStr(__crt0_startup_flags, 2));
if CurrentDSLimit <> $FFFFFFFF then
begin
Debugln('Not $FFFFFFFF...');
Debugln('Probably running under NT or DOSEMU.');
Result := false;
if CurrentDSLimit <> ___djgpp_selector_limit then
begin
{ fix limit back to what it was }
set_segment_limit(get_ds, ___djgpp_selector_limit);
end;
exit;
end;
set_segment_limit(___v2prt0_ds_alias, $FFFFFFFF);
__crt0_startup_flags := __crt0_startup_flags or _CRT0_FLAG_NEARPTR;
Debugln('Nearptr mode enabled successfully.');
Result := true;
end;
procedure DisableNearPtr;
const
_CRT0_FLAG_NEARPTR = $80;
begin
if not NearPtrEnabled then
exit;
Debugln('Trying to disable nearptr (aka "Fat DS") mode...');
__crt0_startup_flags := __crt0_startup_flags and (not _CRT0_FLAG_NEARPTR);
Debugln('Setting DS limit...');
set_segment_limit(get_ds, ___djgpp_selector_limit);
if int31error <> 0 then
Debugln('DPMI error $' + HexStr(int31error, 4));
Debugln('Setting DS alias limit...');
set_segment_limit(___v2prt0_ds_alias, ___djgpp_selector_limit);
if int31error <> 0 then
Debugln('DPMI error $' + HexStr(int31error, 4));
Debugln('Nearptr mode disabled.');
end;
function LFBNearPtrAccessAvailable: Boolean;
begin
Result := LFB0508Mapped or (NearPtrEnabled and LFB0800LinearAddressMapped);
end;
function LFBNearPtrAccessPtr: Pointer;
begin
if LFB0508Mapped then
Result := LFB0508MappedVideoBufferStart
else
if NearPtrEnabled and LFB0800LinearAddressMapped then
Result := Pointer(LFB0800LinearAddress - ___djgpp_base_address)
else
Result := nil;
end;
{procedure TestLFB;
var
pixels: PDWord;
I: Integer;
begin
pixels := LFB0508MappedVideoBufferStart;
for I := 0 to 1000 do
pixels[I] := I;
Readln;
end;}
function CreateLFBSegmentSelector: Boolean;
var
Selector: Word;
procedure InternalFreeLFBSegmentSelector;
begin
if Selector = 0 then
exit;
Debugln('Freeing the LFB descriptor for far ptr LFB access...');
if not free_ldt_descriptor(Selector) then
Debugln('DPMI error $' + HexStr(int31error, 4));
Selector := 0;
end;
begin
Debugln('Allocating a LDT descriptor for far ptr LFB access...');
Selector := allocate_ldt_descriptors(1);
if int31error <> 0 then
begin
Debugln('DPMI error $' + HexStr(int31error, 4));
Result := false;
exit;
end;
Debugln('Got selector ' + IntToStr(Selector));
Debugln('Setting selector base address to ' + HexStr(LFB0800LinearAddress, 8));
set_segment_base_address(Selector, LFB0800LinearAddress);
if int31error <> 0 then
begin
Debugln('DPMI error $' + HexStr(int31error, 4));
Result := false;
InternalFreeLFBSegmentSelector;
exit;
end;
Debugln('Setting segment limit to ' + HexStr((LFBBufferSize - 1) or $FFF, 8));
set_segment_limit(Selector, (LFBBufferSize - 1) or $FFF);
if int31error <> 0 then
begin
Debugln('DPMI error $' + HexStr(int31error, 4));
Result := false;
InternalFreeLFBSegmentSelector;
exit;
end;
LFBSegmentSelector := Selector;
end;
procedure FreeLFBSegmentSelector;
begin
if LFBSegmentSelector = 0 then
exit;
Debugln('Freeing the LFB descriptor for far ptr LFB access...');
if not free_ldt_descriptor(LFBSegmentSelector) then
Debugln('DPMI error $' + HexStr(int31error, 4));
LFBSegmentSelector := 0;
end;
procedure Cleanup;
begin
{ cleanup LFB stuff }
FreeLFBMapping0508;
DisableNearPtr;
FreeLFBSegmentSelector;
FreeLFBMapping0800;
DisposeRealModePalette;
end;
function SetVESAMode(M: Integer; AUseLFB: Boolean): Boolean;
var
ModeAttr: DWord;
lLFBUsed: Boolean;
lReadWindow, lWriteWindow: Integer;
lReadWindowStart, lWriteWindowStart: Integer;
lReadWindowAddress, lWriteWindowAddress: Integer;
lWindowGranularity: DWord;
lWindowSize, lWindowSizeG: DWord;
RealRegs: TRealRegs;
DPMI508Success: Boolean;
begin
Debugln('Setting VBE mode $' + HexStr(VBEModes[M].VBEModeID, 4));
Result := false;
Cleanup;
lLFBUsed := AUseLFB;
if not AUseLFB then
begin
if not VBEModes[M].SupportsWindowed then
exit;
lReadWindow := VBEModes[M].ReadWindow.WindowID;
lReadWindowAddress := VBEModes[M].ReadWindow.Segment shl 4;
lWriteWindow := VBEModes[M].WriteWindow.WindowID;
lWriteWindowAddress := VBEModes[M].WriteWindow.Segment shl 4;
lWindowGranularity := VBEModes[M].WriteWindow.Granularity * 1024;
lWindowSize := VBEModes[M].WriteWindow.Size * 1024;
lWindowSizeG := lWindowSize div lWindowGranularity;
lWindowSize := lWindowSizeG * lWindowGranularity;
end
else
begin
if not VBEModes[M].SupportsLFB then
exit;
DPMI508Success := false;
if TryDPMI508h then
begin
DPMI508Success := MapLFBToLinearSpace0508(VBEModes[M].PhysBasePtr, VideoMemory * 1024);
if not DPMI508Success then
Debugln('DPMI 508h mapping failed, will try other methods to map the lfb...');
end;
if not DPMI508Success then
begin
if not MapLFBToLinearSpace0800(VBEModes[M].PhysBasePtr, VideoMemory * 1024) then
begin
Result := false;
exit;
end;
if TryNearPtr then
begin
if not EnableNearPtr then
Debugln('Enabling nearptr (aka "Fat DS") mode failed, will try other methods...');
end;
if not NearPtrEnabled then
begin
Debugln('Falling back to far ptr lfb access...');
CreateLFBSegmentSelector;
end;
end;
end;
RealRegs.ax := $4F02;
if lLFBUsed then
RealRegs.bx := VBEModes[M].VBEModeID or $4000
else
RealRegs.bx := VBEModes[M].VBEModeID;
realintr($10, RealRegs);
if not CheckVBEStatus(RealRegs.AX) then
begin
Cleanup;
Result := false;
exit;
end;
PaletteDACbits := 6;
with VBEModes[M] do
begin
if (BitsPerPixel = 8) and (MemoryModel = vmmmPackedPixel) then
begin
SetPaletteHW := True;
if (VBEInfoBlock.VBEVersion >= $200) and
(not IsVGA) then {if nonVGA, use func9 to set palette}
SetPaletteHW := False;
if EightBitDACSupported and EightBitDACEnabled then
SwitchTo8bitDAC;
if not SetPaletteHW then
AllocateRealModePalette;
end;
end;
CurrentMode := VBEModes[M];
LFBUsed := lLFBUsed;
ReadWindow := lReadWindow;
WriteWindow := lWriteWindow;
ReadWindowStart := lReadWindowStart;
WriteWindowStart := lWriteWindowStart;
ReadWindowAddress := lReadWindowAddress;
WriteWindowAddress := lWriteWindowAddress;
WindowGranularity := lWindowGranularity;
WindowSize := lWindowSize;
WindowSizeG := lWindowSizeG;
Result := true;
// TestLFB;
end;
procedure GetDPMIInfo;
var
DPMIVersionInfo: TDPMIVersionInfo;
begin
Debugln('GO32 run_mode: ' + IntToStr(get_run_mode));
Debugln('Getting DPMI version...');
get_dpmi_version(DPMIVersionInfo);
if int31error <> 0 then
begin
Debugln('DPMI error $' + HexStr(int31error, 4));
end
else
begin
Debugln('DPMI version: ' + IntToStr(DPMIVersionInfo.major) + '.' + IntToStr(DPMIVersionInfo.minor));
Debugln('DPMI flags: %' + BinStr(DPMIVersionInfo.flags, 16));
Debugln('DPMI cpu type: ' + IntToStr(DPMIVersionInfo.cpu));
Debugln('DPMI virtual master PIC base: $' + HexStr(DPMIVersionInfo.master_pic, 2));
Debugln('DPMI virtual slave PIC base: $' + HexStr(DPMIVersionInfo.slave_pic, 2));
end;
Debugln('Getting DPMI page size...');
DPMIPageSize := get_page_size;
if int31error <> 0 then
begin
Debugln('DPMI error $' + HexStr(int31error, 4));
Debugln('Assuming 4k page size...');
DPMIPageSize := 4096;
end;
if DPMIPageSize = 0 then
begin
Debugln('DPMI reported 0 bytes page size, which is an invalid value, assuming 4k page size!!!');
DPMIPageSize := 4096;
end;
Debugln('Page size is ' + IntToStr(DPMIPageSize) + ' bytes');
end;
procedure RestoreTextMode;
var
RealRegs: TRealRegs;
begin
Cleanup;
RealRegs.ax := $0003;
realintr($10, RealRegs);
CurrentMode := nil;
end;
procedure InitVESA;
begin
if not VESAInit then
VESAInit := True
else
exit;
GetDPMIInfo;
GetVBEInfo;
if VBEPresent then
GetModes;
end;
initialization
VESAInit := False;
RealModePaletteSel := 0;
RealModePaletteSeg := 0;
finalization
Cleanup;
FreeModes;
end.