{ 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 go32fix; 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.