← Back to branch summary

~ubuntu-branches/ubuntu/feisty/fpc/feisty

« back to all changes in this revision

Viewing changes to packages/extra/ptc/dos/vesa/vesa.pp

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2007-01-27 20:08:50 UTC
  • mfrom: (1.2.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070127200850-9mrptaqqjsx9nwa7
Tags: 2.0.4-5
* Fixed Build-Depends.
* Add myself to Uploaders in debian/control.
* Make sure that the sources are really patched before building them.
* Build unit 'libc' on powerpc too.

Show diffs side-by-side

added added

removed removed

Lines of Context:
packages/extra/ptc/dos/vesa/vesa.pp
 
1
{$MODE objfpc}
 
2
{$ASMMODE intel}
 
3
 
 
4
{ $DEFINE DEBUGOUTPUT}
 
5
 
 
6
Unit vesa;
 
7
 
 
8
Interface
 
9
 
 
10
Type
 
11
  TVesaModeInfoBlock = Packed Record
 
12
    {Mandatory information for all VBE revisions}
 
13
    ModeAttributes : Word;        {mode attributes}
 
14
    WinAAttributes : Byte;        {window A attributes}
 
15
    WinBAttributes : Byte;        {window B attributes}
 
16
    WinGranularity : Word;        {window granularity}
 
17
    WinSize : Word;               {window size}
 
18
    WinASegment : Word;           {window A start segment}
 
19
    WinBSegment : Word;           {window B start segment}
 
20
    WinFuncPtr : DWord;           {real mode pointer to window function}
 
21
    BytesPerScanLine : Word;      {bytes per scan line}
 
22
 
 
23
    {Mandatory information for VBE 1.2 and above}
 
24
    XResolution : Word;           {horizontal resolution in pixels or characters}
 
25
    YResolution : Word;           {vertical resolution in pixels or characters}
 
26
    XCharSize : Byte;             {character cell width in pixels}
 
27
    YCharSize : Byte;             {character cell height in pixels}
 
28
    NumberOfPlanes : Byte;        {number of memory planes}
 
29
    BitsPerPixel : Byte;          {bits per pixel}
 
30
    NumberOfBanks : Byte;         {number of banks}
 
31
    MemoryModel : Byte;           {memory model type}
 
32
    BankSize : Byte;              {bank size in KB}
 
33
    NumberOfImagePages : Byte;    {number of images}
 
34
    Reserved : Byte;{=1}          {reserved for page function}
 
35
 
 
36
    {Direct color fields (required for direct/6 and YUV/7 memory models)}
 
37
    RedMaskSize : Byte;           {size of direct color red mask in bits}
 
38
    RedFieldPosition : Byte;      {bit position of lsb of red mask}
 
39
    GreenMaskSize : Byte;         {size of direct color green mask in bits}
 
40
    GreenFieldPosition : Byte;    {bit position of lsb of green mask}
 
41
    BlueMaskSize : Byte;          {size of direct color blue mask in bits}
 
42
    BlueFieldPosition : Byte;     {bit position of lsb of blue mask}
 
43
    RsvdMaskSize : Byte;          {size of direct color reserved mask in bits}
 
44
    RsvdFieldPosition : Byte;     {bit position of lsb of reserved mask}
 
45
    DirectColorModeInfo : Byte;   {direct color mode attributes}
 
46
 
 
47
    {Mandatory information for VBE 2.0 and above}
 
48
    PhysBasePtr : DWord;          {physical address for flat memory frame buffer}
 
49
    Reserved2 : DWord;{=0}        {Reserved - always set to 0}
 
50
    Reserved3 : Word;{=0}         {Reserved - always set to 0}
 
51
 
 
52
    {Mandatory information for VBE 3.0 and above}
 
53
    LinBytesPerScanLine : Word;   {bytes per scan line for linear modes}
 
54
    BnkNumberOfImagePages : Byte; {number of images for banked modes}
 
55
    LinNumberOfImagePages : Byte; {number of images for linear modes}
 
56
    LinRedMaskSize : Byte;        {size of direct color red mask (linear modes)}
 
57
    LinRedFieldPosition : Byte;   {bit position of lsb of red mask (linear modes)}
 
58
    LinGreenMaskSize : Byte;      {size of direct color green mask (linear modes)}
 
59
    LinGreenFieldPosition : Byte; {bit position of lsb of green mask (linear modes)}
 
60
    LinBlueMaskSize : Byte;       {size of direct color blue mask (linear modes)}
 
61
    LinBlueFieldPosition : Byte;  {bit position of lsb of blue mask (linear modes)}
 
62
    LinRsvdMaskSize : Byte;       {size of direct color reserved mask (linear modes)}
 
63
    LinRsvdFieldPosition : Byte;  {bit position of lsb of reserved mask (linear modes)}
 
64
    MaxPixelClock : DWord;        {maximum pixel clock (in Hz) for graphics mode}
 
65
 
 
66
    Reserved4 : Array[1..189] Of Byte; {remainder of ModeInfoBlock}
 
67
  End;
 
68
  PModeInfo = ^TModeInfo;
 
69
  TModeInfo = Record
 
70
    ModeNumber : DWord;
 
71
    VesaModeInfo : TVesaModeInfoBlock;
 
72
  End;
 
73
 
 
74
Var
 
75
  ModeInfo : PModeInfo;
 
76
  NrOfModes : Integer;
 
77
  VBEPresent : Boolean;
 
78
 
 
79
Procedure InitVESA;
 
80
Function SetVESAMode(M : Integer) : Boolean;
 
81
Procedure RestoreTextMode;
 
82
Procedure WriteToVideoMemory(Src : Pointer; Dest : DWord; Size : DWord);
 
83
Procedure SetPalette(Palette : Pointer; First, Num : Integer);
 
84
Procedure GetPalette(Palette : Pointer; First, Num : Integer);
 
85
Function MakeMask(MaskSize, FieldPosition : Integer) : DWord;
 
86
 
 
87
Implementation
 
88
 
 
89
Uses
 
90
  go32;
 
91
 
 
92
Type
 
93
  TVBEInfoBlock = Packed Record
 
94
    {VBE 1.0+}
 
95
    VBESignature : DWord; {'VESA'}
 
96
    VBEVersion : Word;
 
97
    OemStringPtr : DWord; {VbeFarPtr to OEM String}
 
98
    Capabilities : DWord; {Capabilities of graphics controller}
 
99
    VideoModePtr : DWord; {VbeFarPtr to VideoModeList}
 
100
    {added for VBE 1.1+}
 
101
    TotalMemory : Word; {Number of 64kb memory blocks}
 
102
    {added for VBE 2.0+}
 
103
    OemSoftwareRev : Word; {VBE implementation Software revision}
 
104
    OemVendorNamePtr : DWord; {VbeFarPtr to Vendor Name String}
 
105
    OemProductNamePtr : DWord; {VbeFarPtr to Product Name String}
 
106
    OemProductRevPtr : DWord; {VbeFarPtr to Product Revision String}
 
107
    Reserved : Array[1..222] Of Byte; {Reserved for VBE implementation scratch area}
 
108
    OemData : Array[1..256] Of Char; {Data Area for OEM Strings}
 
109
  End;
 
110
 
 
111
Var
 
112
  VBEInfoBlock : TVBEInfoBlock;
 
113
  VideoMemory : DWord;
 
114
  EightBitDACSupported : Boolean;
 
115
  nonVGA : Boolean;
 
116
  SnowyRAMDAC : Boolean;
 
117
  StereoSignalingSupport : Boolean;
 
118
  StereoSignalingVesaEVC : Boolean;
 
119
  OEMString : String;
 
120
  OEMVendorName : String;
 
121
  OEMProductName : String;
 
122
  OEMProductRev : String;
 
123
  OEMSoftwareRev : Integer;
 
124
  CurrentMode : Integer;
 
125
  LFBUsed : Boolean;
 
126
  UseLFB : Boolean;
 
127
 
 
128
  RealModePaletteSel : Word;
 
129
  RealModePaletteSeg : Word;
 
130
  SetPaletteHW : Boolean;
 
131
  PaletteDACbits : Integer;
 
132
 
 
133
  ReadWindow, WriteWindow : Integer;
 
134
  ReadWindowStart, WriteWindowStart : Integer;
 
135
  ReadWindowAddress, WriteWindowAddress : Integer;
 
136
  WindowGranularity : DWord;
 
137
  WindowSize, WindowSizeG : DWord;
 
138
 
 
139
  VESAInit : Boolean;
 
140
 
 
141
  RealRegs : TRealRegs;
 
142
 
 
143
  temp : Pointer;
 
144
 
 
145
Procedure StandardMode(ModeNumber : DWord; Var ModeInfo : TVesaModeInfoBlock);
 
146
 
 
147
Begin
 
148
{
 
149
100 640x400x256
 
150
101 640x480x256
 
151
102 800x600x16
 
152
103 800x600x256
 
153
104 1024x768x16
 
154
105 1024x768x256
 
155
106 1280x1024x16
 
156
107 1280x1024x256
 
157
108 80x60t
 
158
109 132x25t
 
159
10A 132x43t
 
160
10B 132x50t
 
161
10C 132x60t
 
162
10D 320x200x32k
 
163
10E 320x200x64k
 
164
10F 320x200x16.8m
 
165
110 640x480x32k
 
166
111 640x480x64k
 
167
112 640x480x16.8m
 
168
113 800x600x32k
 
169
114 800x600x64k
 
170
115 800x600x16.8m
 
171
116 1024x768x32k
 
172
117 1024x768x64k
 
173
118 1024x768x16.8m
 
174
119 1280x1024x32k
 
175
11A 1280x1024x64k
 
176
11B 1280x1024x16.8m
 
177
}
 
178
  With ModeInfo Do
 
179
  Begin
 
180
    ModeAttributes := ModeAttributes Or 2;
 
181
    Case ModeNumber Of
 
182
      $100 : Begin
 
183
        XResolution := 640;
 
184
        YResolution := 400;
 
185
        XCharSize := 8;
 
186
        YCharSize := 16;
 
187
        NumberOfPlanes := 1;
 
188
        BitsPerPixel := 8;
 
189
        MemoryModel := 4;
 
190
      End;
 
191
      $101 : Begin
 
192
        XResolution := 640;
 
193
        YResolution := 480;
 
194
        XCharSize := 8;
 
195
        YCharSize := 16;
 
196
        NumberOfPlanes := 1;
 
197
        BitsPerPixel := 8;
 
198
        MemoryModel := 4;
 
199
      End;
 
200
      $102 : Begin
 
201
        XResolution := 800;
 
202
        YResolution := 600;
 
203
        XCharSize := 8;
 
204
        YCharSize := 16;
 
205
        NumberOfPlanes := 4;
 
206
        BitsPerPixel := 4;
 
207
        MemoryModel := 3;
 
208
      End;
 
209
      $103 : Begin
 
210
        XResolution := 800;
 
211
        YResolution := 600;
 
212
        XCharSize := 8;
 
213
        YCharSize := 16;
 
214
        NumberOfPlanes := 1;
 
215
        BitsPerPixel := 8;
 
216
        MemoryModel := 4;
 
217
      End;
 
218
      $104 : Begin
 
219
        XResolution := 1024;
 
220
        YResolution := 768;
 
221
        XCharSize := 8;
 
222
        YCharSize := 16;
 
223
        NumberOfPlanes := 4;
 
224
        BitsPerPixel := 4;
 
225
        MemoryModel := 3;
 
226
      End;
 
227
      $105 : Begin
 
228
        XResolution := 1024;
 
229
        YResolution := 768;
 
230
        XCharSize := 8;
 
231
        YCharSize := 16;
 
232
        NumberOfPlanes := 1;
 
233
        BitsPerPixel := 8;
 
234
        MemoryModel := 4;
 
235
      End;
 
236
      $106 : Begin
 
237
        XResolution := 1280;
 
238
        YResolution := 1024;
 
239
        XCharSize := 8;
 
240
        YCharSize := 16;
 
241
        NumberOfPlanes := 4;
 
242
        BitsPerPixel := 4;
 
243
        MemoryModel := 3;
 
244
      End;
 
245
      $107 : Begin
 
246
        XResolution := 1280;
 
247
        YResolution := 1024;
 
248
        XCharSize := 8;
 
249
        YCharSize := 16;
 
250
        NumberOfPlanes := 1;
 
251
        BitsPerPixel := 8;
 
252
        MemoryModel := 4;
 
253
      End;
 
254
      $108 : Begin
 
255
        XResolution := 80;
 
256
        YResolution := 60;
 
257
        XCharSize := 8;
 
258
        YCharSize := 16;
 
259
        NumberOfPlanes := 4;
 
260
        BitsPerPixel := 4;
 
261
        MemoryModel := 0;
 
262
      End;
 
263
      $109 : Begin
 
264
        XResolution := 132;
 
265
        YResolution := 25;
 
266
        XCharSize := 8;
 
267
        YCharSize := 16;
 
268
        NumberOfPlanes := 4;
 
269
        BitsPerPixel := 4;
 
270
        MemoryModel := 0;
 
271
      End;
 
272
      $10A : Begin
 
273
        XResolution := 132;
 
274
        YResolution := 43;
 
275
        XCharSize := 8;
 
276
        YCharSize := 16;
 
277
        NumberOfPlanes := 4;
 
278
        BitsPerPixel := 4;
 
279
        MemoryModel := 0;
 
280
      End;
 
281
      $10B : Begin
 
282
        XResolution := 132;
 
283
        YResolution := 50;
 
284
        XCharSize := 8;
 
285
        YCharSize := 16;
 
286
        NumberOfPlanes := 4;
 
287
        BitsPerPixel := 4;
 
288
        MemoryModel := 0;
 
289
      End;
 
290
      $10C : Begin
 
291
        XResolution := 132;
 
292
        YResolution := 60;
 
293
        XCharSize := 8;
 
294
        YCharSize := 16;
 
295
        NumberOfPlanes := 4;
 
296
        BitsPerPixel := 4;
 
297
        MemoryModel := 0;
 
298
      End;
 
299
      {todo:10D..11B}
 
300
      Else
 
301
        ModeAttributes := ModeAttributes And $FFFD;
 
302
    End;
 
303
//        NumberOfImagePages := 0;{...}
 
304
  End;
 
305
End;
 
306
 
 
307
Function bcd(q : Integer) : Integer;
 
308
 
 
309
Begin
 
310
  q := q And $FF;
 
311
  If ((q And $F) < 10) And ((q Shr 4) < 10) Then
 
312
    bcd := (q And $F) + (q Shr 4) * 10
 
313
  Else
 
314
    bcd := q;
 
315
End;
 
316
 
 
317
Procedure DisposeRealModePalette;
 
318
 
 
319
Begin
 
320
  If RealModePaletteSel = 0 Then
 
321
    Exit;
 
322
  global_dos_free(RealModePaletteSel);
 
323
  RealModePaletteSel := 0;
 
324
  RealModePaletteSeg := 0;
 
325
End;
 
326
 
 
327
Procedure AllocateRealModePalette;
 
328
 
 
329
Var
 
330
  Addr : DWord;
 
331
 
 
332
Begin
 
333
  DisposeRealModePalette;
 
334
  Addr := global_dos_alloc(256*4);
 
335
  RealModePaletteSeg := Addr Shr 16;
 
336
  RealModePaletteSel := Addr And $FFFF;
 
337
End;
 
338
 
 
339
Procedure SetPalette2(Palette : Pointer; Num : Integer); Assembler;
 
340
 
 
341
Asm
 
342
  push es
 
343
 
 
344
  cld
 
345
  mov ax, fs
 
346
  mov es, ax
 
347
  mov esi, [Palette]
 
348
  movzx edi, word [RealModePaletteSeg]
 
349
  shl edi, 4
 
350
  mov ecx, Num
 
351
{  mov edx, 03F3F3F3Fh}
 
352
  mov edx, 0003F3F3Fh
 
353
 
 
354
@@1:
 
355
  lodsd
 
356
 
 
357
  shr eax, 2 {convert 8->6bit}
 
358
  and eax, edx
 
359
 
 
360
  stosd
 
361
  dec ecx
 
362
  jnz @@1
 
363
 
 
364
  pop es
 
365
End;
 
366
 
 
367
Procedure SetPalette3(Palette : Pointer; Num : Integer); Assembler;
 
368
 
 
369
Asm
 
370
  push es
 
371
 
 
372
  cld
 
373
  mov ax, fs
 
374
  mov es, ax
 
375
  mov esi, [Palette]
 
376
  movzx edi, word [RealModePaletteSeg]
 
377
  shl edi, 4
 
378
  mov ecx, Num
 
379
{  mov edx, 07F7F7F7Fh}
 
380
  mov edx, 0007F7F7Fh
 
381
 
 
382
@@1:
 
383
  lodsd
 
384
 
 
385
  shr eax, 1 {convert 8->7bit}
 
386
  and eax, edx
 
387
 
 
388
  stosd
 
389
  dec ecx
 
390
  jnz @@1
 
391
 
 
392
  pop es
 
393
End;
 
394
 
 
395
Procedure SetPaletteHW6(Palette : Pointer; First, Num : Integer);
 
396
 
 
397
Var
 
398
  I : Integer;
 
399
  p : PDWord;
 
400
  c : DWord;
 
401
 
 
402
Begin
 
403
  p := PDWord(Palette);
 
404
  outportb($3C8, First);
 
405
  While Num > 0 Do
 
406
  Begin
 
407
    c := (p^ Shr 2) And $3F3F3F;
 
408
    outportb($3C9, c Shr 16);
 
409
    outportb($3C9, c Shr 8);
 
410
    outportb($3C9, c);
 
411
 
 
412
    Inc(p);
 
413
    Dec(Num);
 
414
  End;
 
415
End;
 
416
 
 
417
Procedure SetPaletteHW7(Palette : Pointer; First, Num : Integer);
 
418
 
 
419
Var
 
420
  I : Integer;
 
421
  p : PDWord;
 
422
  c : DWord;
 
423
 
 
424
Begin
 
425
  p := PDWord(Palette);
 
426
  outportb($3C8, First);
 
427
  While Num > 0 Do
 
428
  Begin
 
429
    c := (p^ Shr 1) And $7F7F7F;
 
430
    outportb($3C9, c Shr 16);
 
431
    outportb($3C9, c Shr 8);
 
432
    outportb($3C9, c);
 
433
 
 
434
    Inc(p);
 
435
    Dec(Num);
 
436
  End;
 
437
End;
 
438
 
 
439
Procedure SetPaletteHW8(Palette : Pointer; First, Num : Integer);
 
440
 
 
441
Var
 
442
  I : Integer;
 
443
  p : PDWord;
 
444
 
 
445
Begin
 
446
  p := PDWord(Palette);
 
447
  outportb($3C8, First);
 
448
  While Num > 0 Do
 
449
  Begin
 
450
    outportb($3C9, p^ Shr 16);
 
451
    outportb($3C9, p^ Shr 8);
 
452
    outportb($3C9, p^);
 
453
 
 
454
    Inc(p);
 
455
    Dec(Num);
 
456
  End;
 
457
End;
 
458
 
 
459
Procedure SetPalette(Palette : Pointer; First, Num : Integer);
 
460
 
 
461
Begin
 
462
  If SetPaletteHW Then
 
463
  Begin
 
464
    Case PaletteDACbits Of
 
465
      8 : SetPaletteHW8(Palette, First, Num);
 
466
      7 : SetPaletteHW7(Palette, First, Num);
 
467
      6 : SetPaletteHW6(Palette, First, Num);
 
468
    End;
 
469
  End
 
470
  Else
 
471
  Begin
 
472
    If PaletteDACbits = 8 Then
 
473
      dosmemput(RealModePaletteSeg, 0, Palette^, Num * 4) {8bits}
 
474
    Else
 
475
      If PaletteDACbits = 7 Then
 
476
        SetPalette3(Palette, Num) {7bits}
 
477
      Else
 
478
        SetPalette2(Palette, Num); {6bits}
 
479
    RealRegs.ax := $4F09;
 
480
    RealRegs.bl := 0;
 
481
    RealRegs.cx := Num;
 
482
    RealRegs.dx := First;
 
483
    RealRegs.es := RealModePaletteSeg;
 
484
    RealRegs.di := 0;
 
485
    realintr($10, RealRegs);
 
486
  End;
 
487
End;
 
488
 
 
489
Procedure GetPalette(Palette : Pointer; First, Num : Integer);
 
490
 
 
491
Begin
 
492
  RealRegs.ax := $4F09;
 
493
  RealRegs.bl := 1;
 
494
  RealRegs.cx := Num;
 
495
  RealRegs.dx := First;
 
496
  RealRegs.es := RealModePaletteSeg;
 
497
  RealRegs.di := 0;
 
498
  realintr($10, RealRegs);
 
499
  {...}
 
500
End;
 
501
 
 
502
Procedure SwitchTo8bitDAC;
 
503
 
 
504
Begin
 
505
  RealRegs.ax := $4F08;
 
506
  RealRegs.bl := 0;
 
507
  RealRegs.bh := 8;
 
508
  realintr($10, RealRegs);
 
509
  PaletteDACbits := RealRegs.bh;
 
510
  If PaletteDACbits < 6 Then
 
511
    PaletteDACbits := 6;
 
512
End;
 
513
 
 
514
Function MakeMask(MaskSize, FieldPosition : Integer) : DWord;
 
515
 
 
516
Var
 
517
  Mask : DWord;
 
518
  I : Integer;
 
519
 
 
520
Begin
 
521
  Mask := 1 Shl FieldPosition;
 
522
  For I := 2 To MaskSize Do
 
523
    Mask := Mask Or (Mask Shl 1);
 
524
  MakeMask := Mask;
 
525
End;
 
526
 
 
527
Function GetRMString(SegOfs : DWord) : String;
 
528
 
 
529
Var
 
530
  S : String;
 
531
  C : Char;
 
532
  Seg, Ofs : Word;
 
533
 
 
534
Begin
 
535
  If SegOfs = 0 Then
 
536
  Begin
 
537
    GetRMString := '';
 
538
    Exit;
 
539
  End;
 
540
  S := '';
 
541
  Ofs := SegOfs And $FFFF;
 
542
  Seg := SegOfs Shr 16;
 
543
  Repeat
 
544
    dosmemget(Seg, Ofs, C, 1);
 
545
    If C <> #0 Then
 
546
    Begin
 
547
      S := S + C;
 
548
      If Ofs = $FFFF Then
 
549
      Begin
 
550
        Ofs := 0;
 
551
        Inc(Seg, $1000);
 
552
      End
 
553
      Else
 
554
        Inc(Ofs);
 
555
    End;
 
556
  Until C = #0;
 
557
  GetRMString := S;
 
558
End;
 
559
 
 
560
Procedure SetWriteWindowStart(WinPos : DWord);
 
561
 
 
562
Begin
 
563
  RealRegs.ax := $4F05;
 
564
  RealRegs.bx := WriteWindow;
 
565
  RealRegs.dx := WinPos;
 
566
  realintr($10, RealRegs);
 
567
End;
 
568
 
 
569
Procedure WriteToVideoMemory(Src : Pointer; Dest : DWord; Size : DWord);
 
570
 
 
571
Var
 
572
  WW : Integer;
 
573
  ToDo : Integer;
 
574
 
 
575
Begin
 
576
  WW := Dest Div WindowGranularity;
 
577
  Dest := Dest Mod WindowGranularity;
 
578
{  Writeln(WindowSize);}
 
579
  While Size > 0 Do
 
580
  Begin
 
581
{    Write(WW, ' ');}
 
582
    SetWriteWindowStart(WW);
 
583
    ToDo := WindowSize - Dest;
 
584
    If Size < ToDo Then
 
585
      ToDo := Size;
 
586
    Asm
 
587
      push es
 
588
      mov esi, Src
 
589
      mov edi, Dest
 
590
      add edi, WriteWindowAddress
 
591
      mov ax, fs
 
592
      mov es, ax
 
593
      mov ecx, ToDo
 
594
      shr ecx, 2
 
595
      cld
 
596
      rep movsd
 
597
      mov ecx, ToDo
 
598
      and ecx, 3
 
599
      jz @@1
 
600
      rep movsb
 
601
@@1:
 
602
      pop es
 
603
    End ['EAX', 'ECX', 'ESI', 'EDI'];
 
604
    Dest := 0;
 
605
    Inc(WW, WindowSizeG);
 
606
{    Inc(WW);}
 
607
    Inc(Src, ToDo);
 
608
    Dec(Size, ToDo);
 
609
  End;
 
610
End;
 
611
 
 
612
{$IFDEF DEBUGOUTPUT}
 
613
Procedure WinAttrib(q : Integer);
 
614
 
 
615
Begin
 
616
  If (q And 1) <> 0 Then
 
617
    Write(' supported')
 
618
  Else
 
619
    Write(' not_supported');
 
620
  If (q And 2) <> 0 Then
 
621
    Write(' readable');
 
622
  If (q And 4) <> 0 Then
 
623
    Write(' writeable');
 
624
  Writeln;
 
625
End;
 
626
{$ENDIF DEBUGOUTPUT}
 
627
 
 
628
Procedure GetModes;
 
629
 
 
630
Type
 
631
  PModesList = ^TModesList;
 
632
  TModesList = Record
 
633
    ModeInfo : TModeInfo;
 
634
    Next : PModesList;
 
635
  End;
 
636
 
 
637
Var
 
638
  First, Last, Run, Tmp : PModesList;
 
639
 
 
640
  Procedure AddToList;
 
641
 
 
642
  Begin
 
643
    If Last = Nil Then
 
644
    Begin
 
645
      New(Last);
 
646
      First := Last;
 
647
    End
 
648
    Else
 
649
    Begin
 
650
      New(Last^.Next);
 
651
      Last := Last^.Next;
 
652
      Last^.Next := Nil;
 
653
    End;
 
654
  End;
 
655
 
 
656
Var
 
657
  I : DWord;
 
658
  Addr : DWord;
 
659
  AddrSeg, AddrSel : Word;
 
660
  VesaModeInfo : TVesaModeInfoBlock;
 
661
  ScanStart, ScanEnd : Integer;
 
662
  ModeAttr : Integer;
 
663
  IsModeOk : Boolean;
 
664
  hasReadWindow, hasWriteWindow : Boolean;
 
665
 
 
666
Begin
 
667
  NrOfModes := -1;
 
668
  First := Nil;
 
669
  Last := Nil;
 
670
  Addr := global_dos_alloc(512);
 
671
  AddrSeg := Addr Shr 16;
 
672
  AddrSel := Addr And $FFFF;
 
673
  ScanStart := 0;
 
674
{  ScanEnd := $7FFF;} {VBE 1.0+ ??}
 
675
{  ScanEnd := $3FFF;} {VBE 1.2+ ??}
 
676
  ScanEnd := $7FF; {VBE 3.0+}
 
677
  {$IFDEF DEBUGOUTPUT}
 
678
  Writeln('scanning modes $', HexStr(ScanStart, 4), '..$', HexStr(ScanEnd, 4));
 
679
  {$ENDIF DEBUGOUTPUT}
 
680
  For I := ScanStart To ScanEnd Do
 
681
  Begin
 
682
    FillChar(VesaModeInfo, SizeOf(VesaModeInfo), 0);
 
683
    dosmemput(AddrSeg, 0, VesaModeInfo, SizeOf(VesaModeInfo));
 
684
    RealRegs.ax := $4F01; {return VBE mode information}
 
685
    RealRegs.cx := I;
 
686
    RealRegs.es := AddrSeg;
 
687
    RealRegs.di := 0;
 
688
    realintr($10, RealRegs);
 
689
    dosmemget(AddrSeg, 0, VesaModeInfo, SizeOf(VesaModeInfo));
 
690
 
 
691
    {display mode info}
 
692
    {$IFDEF DEBUGOUTPUT}
 
693
    If ((VesaModeInfo.ModeAttributes And 1) <> 0) Or
 
694
       (VesaModeInfo.BytesPerScanLine <> 0) Then
 
695
    Begin
 
696
      Writeln('ModeNumber: $', HexStr(I, 4));
 
697
      Write('ModeAttributes:');
 
698
      If (VesaModeInfo.ModeAttributes And 1) <> 0 Then
 
699
        Write(' supported')
 
700
      Else
 
701
        Write(' not_supported');
 
702
      If (VesaModeInfo.ModeAttributes And 2) <> 0 Then
 
703
        Write('')
 
704
      Else
 
705
        Write(' reserved_is_zero(noresolutioninfo_for_vbe1.1-)');
 
706
      If (VesaModeInfo.ModeAttributes And 4) <> 0 Then
 
707
        Write(' TTY')
 
708
      Else
 
709
        Write(' noTTY');
 
710
      If (VesaModeInfo.ModeAttributes And 8) <> 0 Then
 
711
        Write(' color')
 
712
      Else
 
713
        Write(' monochrome');
 
714
      If (VesaModeInfo.ModeAttributes And 16) <> 0 Then
 
715
        Write(' graph')
 
716
      Else
 
717
        Write(' text');
 
718
      If (VesaModeInfo.ModeAttributes And 32) <> 0 Then
 
719
        Write(' nonVGA')
 
720
      Else
 
721
        Write(' VGA');
 
722
      If (VesaModeInfo.ModeAttributes And 64) <> 0 Then
 
723
        Write(' noWINDOWED')
 
724
      Else
 
725
        Write(' WINDOWED');
 
726
      If (VesaModeInfo.ModeAttributes And 128) <> 0 Then
 
727
        Write(' LFB')
 
728
      Else
 
729
        Write(' noLFB');
 
730
      If (VesaModeInfo.ModeAttributes And 256) <> 0 Then
 
731
        Write(' DoubleScanMode_is_available')
 
732
      Else
 
733
        Write('');
 
734
      If (VesaModeInfo.ModeAttributes And 512) <> 0 Then
 
735
        Write(' InterlacedMode_is_available')
 
736
      Else
 
737
        Write('');
 
738
      If (VesaModeInfo.ModeAttributes And 1024) <> 0 Then
 
739
        Write(' TripleBuffering')
 
740
      Else
 
741
        Write('');
 
742
      If (VesaModeInfo.ModeAttributes And 2048) <> 0 Then
 
743
        Write(' StereoscopicDisplaySupport')
 
744
      Else
 
745
        Write('');
 
746
      If (VesaModeInfo.ModeAttributes And 4096) <> 0 Then
 
747
        Write(' DualDisplayStartAddressSupport')
 
748
      Else
 
749
        Write('');
 
750
      Writeln;
 
751
 
 
752
      Write('WinAAtributes:');
 
753
      WinAttrib(VesaModeInfo.WinAAttributes);
 
754
      Write('WinBAttributes:');
 
755
      WinAttrib(VesaModeInfo.WinBAttributes);
 
756
      Writeln('WinGranularity: ', VesaModeInfo.WinGranularity, ' KB');
 
757
      Writeln('WinSize: ', VesaModeInfo.WinSize, ' KB');
 
758
      Writeln('WinASegment: $', HexStr(VesaModeInfo.WinASegment, 4));
 
759
      Writeln('WinBSegment: $', HexStr(VesaModeInfo.WinBSegment, 4));
 
760
      Writeln('WinFuncPtr: ', HexStr(VesaModeInfo.WinFuncPtr Shr 16, 4), ':', HexStr(VesaModeInfo.WinFuncPtr And $FFFF, 4));
 
761
      Writeln('BytesPerScanLine: ', VesaModeInfo.BytesPerScanLine);
 
762
      Writeln('vbe1.2+');
 
763
      Writeln('XResolution: ', VesaModeInfo.XResolution);
 
764
      Writeln('YResolution: ', VesaModeInfo.YResolution);
 
765
      Writeln('XCharSize: ', VesaModeInfo.XCharSize);
 
766
      Writeln('YCharSize: ', VesaModeInfo.YCharSize);
 
767
      Writeln('NumberOfPlanes: ', VesaModeInfo.NumberOfPlanes);
 
768
      Writeln('BitsPerPixel: ', VesaModeInfo.BitsPerPixel);
 
769
      Writeln('NumberOfBanks: ', VesaModeInfo.NumberOfBanks);
 
770
      Write('MemoryModel: ');
 
771
      Case VesaModeInfo.MemoryModel Of
 
772
        0 : Write('Text mode');
 
773
        1 : Write('CGA graphics');
 
774
        2 : Write('Hercules graphics');
 
775
        3 : Write('Planar');
 
776
        4 : Write('Packed pixel');
 
777
        5 : Write('Non-chain 4, 256 color');
 
778
        6 : Write('Direct Color');
 
779
        7 : Write('YUV');
 
780
        8..15 : Write('Reserved, to be defined by VESA');
 
781
        Else
 
782
          Write('To be defined by OEM');
 
783
      End;
 
784
      Writeln('/', VesaModeInfo.MemoryModel);
 
785
      Writeln('BankSize: ', VesaModeInfo.BankSize, ' KB');
 
786
      Writeln('NumberOfImagePages: ', VesaModeInfo.NumberOfImagePages);
 
787
      Writeln('Reserved(=1): ', VesaModeInfo.Reserved);
 
788
      Writeln('RedMaskSize: ', VesaModeInfo.RedMaskSize);
 
789
      Writeln('RedFieldPosition: ', VesaModeInfo.RedFieldPosition);
 
790
      Writeln('GreenMaskSize: ', VesaModeInfo.GreenMaskSize);
 
791
      Writeln('GreenFieldPosition: ', VesaModeInfo.GreenFieldPosition);
 
792
      Writeln('BlueMaskSize: ', VesaModeInfo.BlueMaskSize);
 
793
      Writeln('BlueFieldPosition: ', VesaModeInfo.BlueFieldPosition);
 
794
      Writeln('RsvdMaskSize: ', VesaModeInfo.RsvdMaskSize);
 
795
      Writeln('RsvdFieldPosition: ', VesaModeInfo.RsvdFieldPosition);
 
796
      Write('DirectColorModeInfo:');
 
797
      If (VesaModeInfo.DirectColorModeInfo And 1) <> 0 Then
 
798
        Write(' Color_ramp_is_programmable')
 
799
      Else
 
800
        Write(' Color_ramp_is_fixed');
 
801
      If (VesaModeInfo.DirectColorModeInfo And 2) <> 0 Then
 
802
        Write(' Rsvd_bits_usable_by_app')
 
803
      Else
 
804
        Write(' Rsvd_bits_reserved');
 
805
      Writeln;
 
806
      Writeln('vbe2.0+');
 
807
      Writeln('PhysBasePtr: $', HexStr(VesaModeInfo.PhysBasePtr, 8));
 
808
      Writeln('Reserved2(=0): ', VesaModeInfo.Reserved2);
 
809
      Writeln('Reserved3(=0): ', VesaModeInfo.Reserved3);
 
810
 
 
811
      Writeln;
 
812
{      Write(VesaModeInfo.XResolution, 'x', VesaModeInfo.YResolution, 'x',
 
813
            VesaModeInfo.BitsPerPixel, '-', VesaModeInfo.MemoryModel,
 
814
            'R', VesaModeInfo.RedMaskSize, ':', VesaModeInfo.RedFieldPosition,
 
815
            'G', VesaModeInfo.GreenMaskSize, ':', VesaModeInfo.GreenFieldPosition,
 
816
            'B', VesaModeInfo.BlueMaskSize, ':', VesaModeInfo.BlueFieldPosition,
 
817
            'A', VesaModeInfo.RsvdMaskSize, ':', VesaModeInfo.RsvdFieldPosition, ' ');}
 
818
    End;
 
819
    {$ENDIF DEBUGOUTPUT}
 
820
    {/display mode info}
 
821
 
 
822
    If (VesaModeInfo.ModeAttributes And 1) <> 0 Then
 
823
    Begin
 
824
      If (VesaModeInfo.ModeAttributes And 2) = 0 Then
 
825
      Begin
 
826
        If VBEInfoBlock.VBEVersion >= $0102 Then
 
827
          IsModeOk := False
 
828
        Else
 
829
          StandardMode(I, VesaModeInfo);
 
830
      End;
 
831
      ModeAttr := (VesaModeInfo.ModeAttributes And $C0) Shr 6;
 
832
      IsModeOk := True;
 
833
      If ModeAttr = 1 Then
 
834
        IsModeOk := False;
 
835
      If IsModeOk And ((ModeAttr = 0) Or (ModeAttr = 2)) Then
 
836
      Begin {check windowed}
 
837
        hasReadWindow := False;
 
838
        hasWriteWindow := False;
 
839
        If (VesaModeInfo.WinAAttributes And $01) <> 0 Then
 
840
        Begin
 
841
          If (VesaModeInfo.WinAAttributes And $02) <> 0 Then
 
842
            hasReadWindow := True;
 
843
          If (VesaModeInfo.WinAAttributes And $04) <> 0 Then
 
844
            hasWriteWindow := True;
 
845
        End;
 
846
        If (VesaModeInfo.WinBAttributes And $01) <> 0 Then
 
847
        Begin
 
848
          If (VesaModeInfo.WinBAttributes And $02) <> 0 Then
 
849
            hasReadWindow := True;
 
850
          If (VesaModeInfo.WinBAttributes And $04) <> 0 Then
 
851
            hasWriteWindow := True;
 
852
        End;
 
853
        If (Not hasReadWindow) Or (Not hasWriteWindow) Then
 
854
          IsModeOk := False;
 
855
      End;
 
856
      If IsModeOk And ((ModeAttr = 2) Or (ModeAttr = 3)) Then
 
857
      Begin {check lfb...}
 
858
        {...}
 
859
      End;
 
860
 
 
861
      If IsModeOk Then
 
862
      Begin
 
863
//        Write(HexStr(I, 4), ' ');
 
864
        AddToList;
 
865
        Inc(NrOfModes);
 
866
        Last^.ModeInfo.ModeNumber := I;
 
867
        Last^.ModeInfo.VesaModeInfo := VesaModeInfo;
 
868
      End;
 
869
    End;
 
870
  End;
 
871
  global_dos_free(AddrSel);
 
872
  If ModeInfo <> Nil Then
 
873
    FreeMem(ModeInfo);
 
874
  If NrOfModes <> -1 Then
 
875
    ModeInfo := GetMem((NrOfModes + 1) * SizeOf(TModeInfo))
 
876
  Else
 
877
    ModeInfo := Nil;
 
878
  Run := First;
 
879
  For I := 0 To NrOfModes Do
 
880
  Begin
 
881
    ModeInfo[I] := Run^.ModeInfo;
 
882
    Tmp := Run;
 
883
    Run := Run^.Next;
 
884
    Dispose(Tmp);
 
885
  End;
 
886
  {$IFDEF DEBUGOUTPUT}
 
887
  Writeln;
 
888
  {$ENDIF DEBUGOUTPUT}
 
889
End;
 
890
 
 
891
Procedure GetVBEInfo;
 
892
 
 
893
Var
 
894
  Addr : DWord;
 
895
  AddrSeg : Word;
 
896
  AddrSel : Word;
 
897
  tmp : DWord;
 
898
 
 
899
Begin
 
900
  Addr := global_dos_alloc(512);
 
901
  AddrSeg := Addr Shr 16;
 
902
  AddrSel := Addr And $FFFF;
 
903
  VBEInfoBlock.VBESignature := $32454256; {'VBE2'}
 
904
  dosmemput(AddrSeg, 0, VBEInfoBlock, 4);
 
905
  RealRegs.ax := $4F00;
 
906
  RealRegs.es := AddrSeg;
 
907
  RealRegs.di := 0;
 
908
  realintr($10, RealRegs);
 
909
  VBEPresent := RealRegs.al = $4F;
 
910
  If VBEPresent Then
 
911
  Begin
 
912
    dosmemget(AddrSeg, 0, VBEInfoBlock, SizeOf(VBEInfoBlock));
 
913
    {todo: check for 'VESA' id string}
 
914
    VideoMemory := VBEInfoBlock.TotalMemory * 64;
 
915
    EightBitDACSupported := (VBEInfoBlock.Capabilities And 1) <> 0;
 
916
    nonVGA := (VBEInfoBlock.Capabilities And 2) <> 0;
 
917
    SnowyRAMDAC := (VBEInfoBlock.Capabilities And 4) <> 0;
 
918
    StereoSignalingSupport := (VBEInfoBlock.Capabilities And 8) <> 0;
 
919
    StereoSignalingVesaEVC := (VBEInfoBlock.Capabilities And 16) <> 0;
 
920
    OEMString := GetRMString(VBEInfoBlock.OemStringPtr);
 
921
    If VBEInfoBlock.VBEVersion >= $0200 Then
 
922
    Begin
 
923
      OEMVendorName := GetRMString(VBEInfoBlock.OemVendorNamePtr);
 
924
      OEMProductName := GetRMString(VBEInfoBlock.OemProductNamePtr);
 
925
      OEMProductRev := GetRMString(VBEInfoBlock.OemProductRevPtr);
 
926
      OEMSoftwareRev := VBEInfoBlock.OemSoftwareRev;
 
927
    End
 
928
    Else
 
929
    Begin
 
930
      OEMVendorName := '';
 
931
      OEMProductName := '';
 
932
      OEMProductRev := '';
 
933
      OEMSoftwareRev := -1;
 
934
    End;
 
935
  End;
 
936
  global_dos_free(AddrSel);
 
937
 
 
938
  {$IFDEF DEBUGOUTPUT}
 
939
  If VBEPresent Then
 
940
  Begin
 
941
    Writeln('VBEVersion: ', bcd(VBEInfoBlock.VBEVersion Shr 8), '.', bcd(VBEInfoBlock.VBEVersion And $FF));
 
942
    Writeln('VideoMemory: ', VideoMemory, ' KB');
 
943
    Writeln('EightBitDACSupported: ', EightBitDACSupported);
 
944
    Writeln('nonVGA: ', nonVGA);
 
945
    Writeln('SnowyRAMDAC: ', SnowyRAMDAC);
 
946
    Writeln('StereoSignalingSupport: ', StereoSignalingSupport);
 
947
    If StereoSignalingSupport Then
 
948
     If StereoSignalingVesaEVC Then
 
949
       Writeln('Stereo signaling supported via VESA EVC connector')
 
950
     Else
 
951
       Writeln('Stereo signaling supported via external VESA stereo connector');
 
952
    If OEMString <> '' Then
 
953
      Writeln('OEMString: ', OEMString);
 
954
    If OEMVendorName <> '' Then
 
955
      Writeln('OEMVendorName: ', OEMVendorName);
 
956
    If OEMProductName <> '' Then
 
957
      Writeln('OEMProductName: ', OEMProductName);
 
958
    If OEMProductRev <> '' Then
 
959
      Writeln('OEMProductRev: ', OEMProductRev);
 
960
    If OEMSoftwareRev <> -1 Then
 
961
      Writeln('OEMSoftwareRev: ', bcd(OEMSoftwareRev Shr 8), '.', bcd(OEMSoftwareRev And $FF));
 
962
    Write('VideoModeList:');
 
963
    tmp := (VBEInfoBlock.VideoModePtr Shr 16) * 16 + (VBEInfoBlock.VideoModePtr And $FFFF);
 
964
    While MemW[tmp] <> $FFFF Do
 
965
    Begin
 
966
      Write(' $', HexStr(MemW[tmp], 4));
 
967
      Inc(tmp, 2);
 
968
    End;
 
969
    Writeln;
 
970
    Writeln;
 
971
  End;
 
972
  {$ENDIF DEBUGOUTPUT}
 
973
End;
 
974
 
 
975
Function SetVESAMode(M : Integer) : Boolean;
 
976
 
 
977
Var
 
978
  ModeAttr : DWord;
 
979
  lLFBUsed : Boolean;
 
980
  lReadWindow, lWriteWindow : Integer;
 
981
  lReadWindowStart, lWriteWindowStart : Integer;
 
982
  lReadWindowAddress, lWriteWindowAddress : Integer;
 
983
  lWindowGranularity : DWord;
 
984
  lWindowSize, lWindowSizeG : DWord;
 
985
 
 
986
Begin
 
987
  SetVESAMode := False;
 
988
  DisposeRealModePalette;
 
989
  ModeAttr := (ModeInfo[M].VesaModeInfo.ModeAttributes And $C0) Shr 6;
 
990
  Case ModeAttr Of
 
991
    0 : lLFBUsed := False; {windowed frame buffer only}
 
992
    2 : lLFBUsed := UseLFB; {both windowed and linear}
 
993
    3 : lLFBUsed := True; {linear frame buffer only}
 
994
  End;
 
995
  If Not lLFBUsed Then
 
996
  Begin
 
997
    With ModeInfo[M].VesaModeInfo Do
 
998
    Begin
 
999
      lReadWindow := -1;
 
1000
      lWriteWindow := -1;
 
1001
      If (WinAAttributes And $01) <> 0 Then
 
1002
      Begin
 
1003
        If (WinAAttributes And $02) <> 0 Then
 
1004
          lReadWindow := 0;
 
1005
        If (WinAAttributes And $04) <> 0 Then
 
1006
          lWriteWindow := 0;
 
1007
      End;
 
1008
      If (lReadWindow = -1) Or (lWriteWindow = -1) Then
 
1009
        If (WinBAttributes And $01) <> 0 Then
 
1010
        Begin
 
1011
          If (lReadWindow = -1) And ((WinBAttributes And $02) <> 0) Then
 
1012
            lReadWindow := 1;
 
1013
          If (lWriteWindow = -1) And ((WinBAttributes And $04) <> 0) Then
 
1014
            lWriteWindow := 1;
 
1015
        End;
 
1016
      Case lReadWindow Of
 
1017
        -1 : Exit{err};
 
1018
        0 : lReadWindowAddress := WinASegment Shl 4;
 
1019
        1 : lReadWindowAddress := WinBSegment Shl 4;
 
1020
      End;
 
1021
      Case lWriteWindow Of
 
1022
        -1 : Exit{err};
 
1023
        0 : lWriteWindowAddress := WinASegment Shl 4;
 
1024
        1 : lWriteWindowAddress := WinBSegment Shl 4;
 
1025
      End;
 
1026
      lWindowGranularity := WinGranularity * 1024;
 
1027
      lWindowSize := WinSize * 1024;
 
1028
      lWindowSizeG := lWindowSize Div lWindowGranularity;
 
1029
      lWindowSize := lWindowSizeG * lWindowGranularity;
 
1030
    End;
 
1031
  End
 
1032
  Else
 
1033
  Begin
 
1034
    {TODO: lfb}
 
1035
  End;
 
1036
  RealRegs.ax := $4F02;
 
1037
  If lLFBUsed Then
 
1038
    RealRegs.bx := ModeInfo[M].ModeNumber Or $4000
 
1039
  Else
 
1040
    RealRegs.bx := ModeInfo[M].ModeNumber;
 
1041
  realintr($10, RealRegs);
 
1042
  PaletteDACbits := 6;
 
1043
  With ModeInfo[M].VesaModeInfo Do
 
1044
  Begin
 
1045
    If (BitsPerPixel = 8) And (MemoryModel = 4{packed pixel}) Then
 
1046
    Begin
 
1047
      SetPaletteHW := True;
 
1048
      If (VBEInfoBlock.VBEVersion >= $200) And
 
1049
         ((ModeAttributes And 32) <> 0) Then {if nonVGA, use func9 to set palette}
 
1050
        SetPaletteHW := False;
 
1051
 
 
1052
      If EightBitDACSupported Then
 
1053
        SwitchTo8bitDAC;
 
1054
 
 
1055
      If Not SetPaletteHW Then
 
1056
        AllocateRealModePalette;
 
1057
    End;
 
1058
  End;
 
1059
 
 
1060
  LFBUsed := lLFBUsed;
 
1061
  ReadWindow := lReadWindow;
 
1062
  WriteWindow := lWriteWindow;
 
1063
  ReadWindowStart := lReadWindowStart;
 
1064
  WriteWindowStart := lWriteWindowStart;
 
1065
  ReadWindowAddress := lReadWindowAddress;
 
1066
  WriteWindowAddress := lWriteWindowAddress;
 
1067
  WindowGranularity := lWindowGranularity;
 
1068
  WindowSize := lWindowSize;
 
1069
  WindowSizeG := lWindowSizeG;
 
1070
 
 
1071
  SetVESAMode := True;
 
1072
End;
 
1073
 
 
1074
Procedure RestoreTextMode;
 
1075
 
 
1076
Begin
 
1077
  DisposeRealModePalette;
 
1078
  RealRegs.ax := $0003;
 
1079
  realintr($10, RealRegs);
 
1080
End;
 
1081
 
 
1082
Procedure InitVESA;
 
1083
 
 
1084
Begin
 
1085
  If Not VESAInit Then
 
1086
    VESAInit := True
 
1087
  Else
 
1088
    Exit;
 
1089
  GetVBEInfo;
 
1090
  If VBEPresent Then
 
1091
    GetModes;
 
1092
End;
 
1093
 
 
1094
Initialization
 
1095
  VESAInit := False;
 
1096
  CurrentMode := -1;
 
1097
  UseLFB := {True}False;
 
1098
  ModeInfo := Nil;
 
1099
  RealModePaletteSel := 0;
 
1100
  RealModePaletteSeg := 0;
 
1101
 
 
1102
Finalization
 
1103
  temp := ModeInfo;
 
1104
  ModeInfo := Nil;
 
1105
  If temp <> Nil Then
 
1106
    FreeMem(temp);
 
1107
  DisposeRealModePalette;
 
1108
 
 
1109
End.