Collection of Hack-Phreak Scene Programs/cleanhpvac.zip/cleanhpvac/VGADOC4B.ZIP/DEFVGA.PAS

Pascal/Delphi Source File | 1995-09-29 | 31KB | 1,212 lines

type
  str10 = string[10];

const

  hx:array[0..15] of char='0123456789ABCDEF';

  Debug:boolean=false;      {If set step through video tests one by one}
  Auto_test:boolean=false;  {If set run tests automatically}


  {Keys:}
  Ch_Cr       =  $0D;
  Ch_Esc      =  $1B;
  Ch_F1       = $13B;
  Ch_F2       = $13C;
  Ch_F3       = $13D;
  Ch_F4       = $13E;
  Ch_F5       = $13F;
  Ch_F6       = $140;
  Ch_F7       = $141;
  Ch_F8       = $142;
  Ch_Home     = $147;
  Ch_ArUp     = $148;
  Ch_PgUp     = $149;
  Ch_ArLeft   = $14B;
  Ch_ArRight  = $14D;
  Ch_End      = $14F;
  Ch_ArDown   = $150;
  Ch_PgDn     = $151;
  Ch_Ins      = $152;
  Ch_Del      = $153;


    {Standard segment defines}
  Seg0000 = $0000;    {Interupt table}
  Seg0040 = $0040;    {BIOS data segment}
  SegA000 = $A000;    {Graphics Video buffer}
  SegA800 = $A800;    {Graphics Video buffer - upper half}
  SegB000 = $B000;    {Mono Text mode buffer}
  SegB800 = $B800;    {Color Text mode buffer}
  SegC000 = $C000;    {BIOS ROM segment}

  {Gamma correction types}
  GAM_None  =  0;    {No Gamma correction}
  GAM_CanDo =  1;    {}
  GAM_LeftJ =  2;    {left justify Red&Blue 1bit each}
  GAM_Left8 =  4;    {Left justify to 8bits}
  GAM_8bit  =  8;    {DAC Gamma registers are 8bit (not 6)}

type
  CursorType=Array[0..31] of longint;  {32 lines of 32 pixels}
  charr =array[1..255] of char;
  chptr =^charr;


var
  rp:registers;

  video:string[20];
  _crt:string[20];
  secondary:string[20];

  planes:word;     {number of video planes}


  dacHWcursor:boolean;   {True if we use the DAC cursor, rather than the VGA one}


  vseg:word;         {Video buffer base segment}
  biosseg:word;

  curmode:word;      {Current mode number}
  memmode:byte;      {current memory mode}
  crtc:word;         {I/O address of CRTC registers}
  pixels:word;       {Pixels in a scanline in current mode}
  lins:word;         {lines in current mode}
  bytes:longint;     {bytes in a scanline}

  force_chip:byte;
  force_mm:word;       {Forced memory size in Kbytes}
  force_version:word;  {Forced chip version}
  clocktest:boolean;   {Set false to disable clocktesting.}


  extpixfact:word;  {The number of times each pixel is shown}
  extlinfact:word;  {The number of times each scan line is shown}
  charwid   :word;  {Character width in pixels}
  charhigh  :word;  {Character height in scanlines}
  calcvseg:word;
  calcpixels,       {Calculated displayed pixels per scanline}
  calclines,        {    "      displayed scanlines}
  calchtot,         {    "      total pixels/scanline}
  calcvtot,         {    "      total lines/frame}
  calchblks,        {    "      Hor. Blanking Start}
  calchblke,        {    "      Hor Blanking End (see hblkmask)}
  calchrtrs,        {    "      Hor Retrace Start}
  calchrtre,        {    "      Hor Retrace End (see hrtrmask)}
  calcvblks,        {    "      Vert Blanking Start}
  calcvblke,        {    "      Vert Blanking End (see vblkmask)}
  calcvrtrs,        {    "      Vert Retrace Start}
  calcvrtre,        {    "      Vert Retrace End (see vrtrmask)}
  hblkmask,         {    "      }
  hrtrmask,         {    "      }
  vblkmask,         {    "      }
  vrtrmask,         {    "      }
  calcbytes:word;
  calcmmode:byte;


  vclk,hclk,fclk:longint;  {Pixel (kHz), Line (Hz) & Frame (mHz) clocks}
  ilace:boolean;


  daccomm:word;      {The result of the last dac2comm}


  BWlow,BWhigh:longint;  {Bandwidth requirement - low & high in Kbytes/sec}


  (* Interface declarations for functions. In DEFVGA.PAS *)


  (* Utility & User interfrace functions*)
procedure disable; {Disable interupts}

procedure enable;  {Enable interrupts}

function gtstr(var cp:char):string;

function getkey:word;              {Waits for a key, and returns the keyID}

function peekkey:word;             {Checks for a key, and returns the keyID}

procedure pushkey(k:word);         {Simulates a keystroke}

  {Pretend the last key was pushed again}
procedure repeatkey;

function strip(s:string):string;   {strip leading and trailing spaces}

function upstr(s:string):string;   {convert a string to upper case}

function istr(w:longint):str10;    {convert number to string}

function dehex(s:string):longint;  {Hex string to number}

function hex2(w:word):str10;       {convert number to 2digit hex string}

function hex4(w:word):str10;       {convert number to 4digit hex string}

function hex8(w:longint):str10;       {convert number to 4digit hex string}

procedure swapbyte(var a,b:byte);  {Swap the 2 bytes}

function clipstr(var s:string):string;   {Cuts & returns the first non-space
                                          substring from s}

  {BIOS & lowlevel I/O functions}

procedure vio(ax:word);         {INT 10h reg ax=AX. other reg. set from RP
                                 on return rp.ax=reg AX}

procedure viop(ax,bx,cx,dx:word;p:pointer);
                                {INT 10h reg AX-DX, ES:DI = p}

function inp(reg:word):byte;      {Reads a byte from I/O port REG}

function inpw(reg:word):word;     {Reads a word from I/O port REG}

function inpl(reg:word):longint;  {Reads a DWORD from I/O port REG}

procedure outp(reg,val:word);    {Write the low byte of VAL to I/O port REG}

procedure outpw(reg,val:word);    {Write the word byte of VAL to I/O port REG}

procedure outpl(reg:word;val:longint);    {Write the word byte of VAL to I/O port REG}

  {Outputs a 32bit value as a single OUT DX,EAX - requires 386 or better}
procedure outplong(reg:word;val:longint);

  {Inputs a 32bit value as a single IN EAX,DX - requires 386 or better}
function inplong(reg:word):longint;


function rdinx(pt,inx:word):word;       {read register PT index INX}

procedure wrinx(pt,inx,val:word);       {write VAL to register PT index INX}

procedure wrinx2(pt,inx,val:word);       {write VAL to register PT index INX}

procedure wrinx2m(pt,inx,val:word);       {write VAL to register PT index INX}

procedure wrinx3(pt,inx:word;val:longint);       {write VAL to register PT index INX}

procedure wrinx3m(pt,inx:word;val:longint);       {write VAL to register PT index INX}

procedure modinx(pt,inx,mask,nwv:word);  {In register PT index INX sets
                                          the bits in MASK as in NWV
                                          the other are left unchanged}

procedure setinx(pt,inx,val:word);

procedure clrinx(pt,inx,val:word);

procedure modreg(reg,mask,nwv:word);  {In register PT index INX sets
                                          the bits in MASK as in NWV
                                          the other are left unchanged}

procedure setreg(reg,val:word);

procedure clrreg(reg,val:word);

procedure modregw(reg,mask,nwv:word);  {In register PT index INX sets
                                          the bits in MASK as in NWV
                                          the other are left unchanged}

procedure setregw(reg,val:word);

procedure clrregw(reg,val:word);

  {Lowlevel DAC stuff}
function trigdac:word;  {Reads $3C6 4 times}

procedure setDACstd;
procedure setdac8(on:boolean);
function setdac15:boolean;
function setdac16:boolean;
function setdac24:boolean;
function setdac32:boolean;

function setDACgamma(on:boolean):word;


function setDACpage(index:word):word;

procedure clearDACpage;

function rdDACreg(index:word):word;

procedure wrDACreg(index,val:word);

procedure clrDACreg(index,val:word);

procedure setDACreg(index,val:word);

procedure modDACreg(index,msk,val:word);


function getdaccomm:word;

procedure dac2comm;

procedure dac2pel;


  {Probe clocks, should really be in IDVGA ??}
procedure findclocks;


  {The LOG functions writes output data to both the screen and the file
   WHATVGA.TXT, to provide a log in case of lockup}

procedure openlog(scr:boolean);

procedure wrlog(s:string);

procedure closelog;





  (* HW cursor, BitBLT, linedraw and clock function in BITBLT.PAS *)

procedure setHWcurmap(VAR map:CursorType);

procedure HWcuronoff(on:boolean);

procedure setHWcurpos(X,Y:word);

procedure setHWcurcol(fgcol,bkcol:longint);


procedure setZoomWindow(Xs,Ys,Xe,Ye:word);

procedure setZoomAdr(AdrX,AdrY:word);

procedure ZoomOnOff(On:boolean);

procedure setZoomFactor(Fx,Fy:word);

procedure vesamodeinfo(md:word;var vbedata);


procedure fillrect(xst,yst,dx,dy:word;col:longint);

procedure copyrect(srcX,srcY,dstX,dstY,dx,dy:word);

procedure line(x0,y0,x1,y1:integer;col:longint);

procedure setclk(Nbr,divi:word);

function getclk(var divisor,divid:word):word;

function getClockFreq:longint;    {Effective pixel clock in kHz}




  (* Bank, mode and Vstart rutines, in SUPERVGA.PAS *)

procedure setbank(bank:word);

procedure setRbank(bank:word);

procedure setvstart(x,y:word);       {Set the display start to (x,y)}

function setmode(md:word;clear:boolean):boolean;

procedure SetTextMode;



procedure SetRGBPal(inx,r,g,b:word);

procedure SelectVideo(Item:word);

function rgb(r,g,b:word):longint;    {Converts RGB values to pixel in the
                                      current pixelformat }

  {Returns the pixel BIT address}
function pixeladdress(x,y:word):longint;

implementation
uses idvga;


var

  clocktbl:array[0..31] of longint;


procedure disable; (* Disable interupts *)
begin
  inline($fa);  (* CLI instruction *)
end;


procedure enable;  (* Enable interrupts *)
begin
  inline($fb);  (* STI instruction *)
end;


function gtstr(var cp:char):string;
var x:word;
  s:string;
  str:chptr;
begin
  str:=chptr(@cp);
  s:='';x:=1;
  if str<>NIL then
    while (x<255) and (str^[x]<>#0) do
    begin
      if str^[x]<>#7 then s:=s+str^[x];
      inc(x);
    end;
  gtstr:=s;
end;

const
  key_stack:word=0;    {Stored key stroke 0=none}
  lastkey:word=0;

function getkey:word;
var c:char;
begin
  if key_stack<>0 then
  begin
    lastkey:=key_stack;
    key_stack:=0;
  end
  else begin
    c:=readkey;
    if c=#0 then lastkey:=$100+ord(readkey)
            else lastkey:=ord(c);
  end;
  getkey:=lastkey;
end;

function peekkey:word;
begin
  if (key_stack=0) and not keypressed then peekkey:=0
                                      else peekkey:=getkey;
end;

procedure pushkey(k:word);  {Simulates a key stroke}
var ch:char;
begin
  key_stack:=k;
  while keypressed do ch:=readkey;
end;

  {Pretend the last key was pushed again}
procedure repeatkey;
begin
  pushkey(lastkey);
end;

  {Swap the 2 bytes}
procedure swapbyte(var a,b:byte);
var c:byte;
begin
  c:=a;
  a:=b;
  b:=c;
end;


function strip(s:string):string;       {strip leading and trailing spaces}
begin
  while s[length(s)]=' ' do dec(s[0]);
  while copy(s,1,1)=' ' do delete(s,1,1);
  strip:=s;
end;

function upstr(s:string):string;       {convert a string to upper case}
var x:word;
begin
  for x:=1 to length(s) do
    s[x]:=upcase(s[x]);
  upstr:=s;
end;

function istr(w:longint):str10;
var s:str10;
begin
  str(w,s);
  istr:=s;
end;


function hex2(w:word):str10;
begin
  hex2:=hx[(w shr 4) and 15]+hx[w and 15];
end;

function hex4(w:word):str10;
begin
  hex4:=hex2(hi(w))+hex2(lo(w));
end;

function hex8(w:longint):str10;
begin
  hex8:=hex4(w shr 16)+hex4(w);
end;

function dehex(s:string):longint;
var x:word;
    l:longint;
    c:char;
begin
  l:=0;
  for x:=1 to length(s) do
  begin
    c:=s[x];
    case c of
      '0'..'9':l:=(l shl 4)+(ord(c) and 15);
      'a'..'f','A'..'F':
               l:=(l shl 4)+(ord(c) and 15 +9);
    end;
  end;
  dehex:=l;
end;

function clipstr(var s:string):string;   {Cuts & returns the first non-space
                                          substring from s}
var
  i:integer;
begin
  i:=0;
  while s[i+1]=' ' do inc(i);
  delete(s,1,i);
  i:=0;
  while (i<length(s)) and (s[i+1]>' ') do inc(i);
  clipstr:=copy(s,1,i);
  delete(s,1,i);
end;


procedure vio(ax:word);         {INT 10h reg ax=AX. other reg. set from RP
                                 on return rp.ax=reg AX}
begin
  rp.ax:=ax;
  intr($10,rp);
end;

procedure viop(ax,bx,cx,dx:word;p:pointer);
begin                            {INT 10h reg AX-DX, ES:DI = p}
  rp.ax:=ax;
  rp.bx:=bx;
  rp.cx:=cx;
  rp.dx:=dx;
  rp.di:=ofs(p^);
  rp.es:=seg(p^);
  intr($10,rp);
end;

function inp(reg:word):byte;     {Reads a byte from I/O port REG}
begin
  reg:=port[reg];
  inp:=reg;
end;


function inpw(reg:word):word;    {Reads a word from I/O port REG}
begin
  reg:=portw[reg];
  inpw:=reg;
end;

function inpl(reg:word):longint;    {Reads a word from I/O port REG}
var l:longint;
begin
  l:=portw[reg];
  inpl:=l+(longint(portw[reg+2]) shl 16);
end;

  {Inputs a 32bit value as a single IN EAX,DX - requires 386 or better}
function inplong(reg:word):longint;
var l:longint;
begin
  inline($8B/$56/<reg/$66/$ED/$66/$89/$46/<l);
  inplong:=l;
end;

procedure outp(reg,val:word);    {Write the low byte of VAL to I/O port REG}
begin
  port[reg]:=val;
end;

procedure outpw(reg,val:word);
begin
  portw[reg]:=val;
end;

procedure outpl(reg:word;val:longint);    {Write the Dword of VAL to I/O port REG}
begin
  portw[reg]  :=val;
  portw[reg+2]:=val shr 16;
end;

  {Outputs a 32bit value as a single OUT DX,EAX - requires 386 or better}
procedure outplong(reg:word;val:longint);
begin
    {mov dx,[BP+reg] mov eax,[BP+val]  out dx,eax}
  inline($8B/$56/<reg/$66/$8B/$46/<val/$66/$EF);
end;


function rdinx(pt,inx:word):word;       {read register PT index INX}
var x:word;
begin
  if pt=$3C0 then
  begin
    x:=inp(CRTC+6);    {Reset Attribute Data/Address Flip-Flop}
    outp($3C0,inx and $DF);    {Clear bit 5 of index}
    for x:=1 to 10 do;
    rdinx:=inp($3C1);    {delay}
    x:=inp(CRTC+6);    {Reset Attribute Data/Address Flip-Flop}
    for x:=1 to 10 do;   {delay}
    outp($3C0,$20);    {Set index bit 5 to keep display alive}
    x:=inp(CRTC+6);    {Reset Attribute Data/Address Flip-Flop}
  end
  else begin
    outp(pt,inx);
    rdinx:=inp(pt+1);
  end;
end;

procedure wrinx(pt,inx,val:word);       {write VAL to register PT index INX}
var x:word;
begin
  if pt=$3C0 then
  begin
    x:=inp(CRTC+6);
    outp($3C0,inx and $DF);
    outp($3C0,val);
    x:=inp(CRTC+6);    {If Attribute Register then reset Flip-Flop}
    outp($3C0,$20);
    x:=inp(CRTC+6);
  end
  else begin
    outp(pt,inx);
    outp(pt+1,val);
  end;
end;

procedure wrinx2(pt,inx,val:word);
begin
  wrinx(pt,inx,lo(val));
  wrinx(pt,inx+1,hi(val));
end;

procedure wrinx3(pt,inx:word;val:longint);
begin
  wrinx(pt,inx,lo(val));
  wrinx(pt,inx+1,hi(val));
  wrinx(pt,inx+2,val shr 16);
end;

procedure wrinx2m(pt,inx,val:word); {Write VAL to the index pair (INX,INX+1)}
begin                               {in motorola (big endian) format}
  wrinx(pt,inx,hi(val));
  wrinx(pt,inx+1,lo(val));
end;

procedure wrinx3m(pt,inx:word;val:longint);
begin
  wrinx(pt,inx+2,lo(val));
  wrinx(pt,inx+1,hi(val));
  wrinx(pt,inx,val shr 16);
end;

procedure modinx(pt,inx,mask,nwv:word);  {In register PT index INX sets
                                          the bits in MASK as in NWV
                                          the other are left unchanged}
var temp:word;
begin
  temp:=(rdinx(pt,inx) and (not mask))+(nwv and mask);
  wrinx(pt,inx,temp);
end;

procedure modreg(reg,mask,nwv:word);  {In register REG sets the bits in
                                       MASK as in NWV other are left unchanged}
var temp:word;
begin
  temp:=(inp(reg) and (not mask))+(nwv and mask);
  outp(reg,temp);
end;


procedure setinx(pt,inx,val:word);
var x:word;
begin
  x:=rdinx(pt,inx);
  wrinx(pt,inx,x or val);
end;

procedure clrinx(pt,inx,val:word);
var x:word;
begin
  x:=rdinx(pt,inx);
  wrinx(pt,inx,x and (not val));
end;

procedure setreg(reg,val:word);
begin
  outp(reg,inp(reg) or val);
end;

procedure clrreg(reg,val:word);
begin
  outp(reg,inp(reg) and (not val));
end;

procedure modregw(reg,mask,nwv:word);  {In register REG sets the bits in
                                       MASK as in NWV other are left unchanged}
var temp:word;
begin
  temp:=(inpw(reg) and (not mask))+(nwv and mask);
  outpw(reg,temp);
end;

procedure setregw(reg,val:word);
begin
  outpw(reg,inpw(reg) or val);
end;

procedure clrregw(reg,val:word);
begin
  outpw(reg,inpw(reg) and (not val));
end;


  {The LOG functions writes output data to both the screen and the file
   WHATVGA.TXT, to provide a log in case of lockup}
var
  logfile:text;
  wrscr:boolean;

procedure openlog(scr:boolean);
begin
  assign(logfile,'whatvga.txt');
  rewrite(logfile);
  wrscr:=scr;
  if scr then SetTextMode;
end;

procedure wrlog(s:string);
begin
  if wrscr then writeln(s);
  writeln(logfile,s);
end;

procedure closelog;
begin
  close(logfile);
end;




  {Select the mode to use for the clock test, preferable a 25.175MHz one!
   Returns the frequency (in kHz for the base freq}
function setstdmode:longint;
var md:integer;
begin
  setstdmode:=25175;
  case cv.chip of
    __Mach32:md:=$321;
    __Mach64:begin
               md:=$1292;
               setstdmode:=28322;
             end;
  {  __Compaq:if cv.version>=CPQ_QV then md:=$32
                                   else md:=$12; }
       __AGX:begin
               md:=$64;
               setstdmode:=44900;
             end;
  else md:=$12;
  end;
  if setmode(md,false) then;
end;


function Vretrace:boolean;
begin
  case cv.chip of
    __Mach64:VRetrace:=memw[cv.Xseg:$12]>=memw[cv.Xseg:$0A];
    __Mach32:VRetrace:=inpw($CEEE)>=inpw($CAEE);   {Hm!!}
       __AGX:if (inp(cv.IOadr+5) and 1)>0 then
             begin
               outp(cv.IOadr+5,1);  {Reset blanking flag}
               VRetrace:=true;
             end
             else Vretrace:=false;
  else
    VRetrace:=(inp(crtc+6) and 8)>0;     {3D4h/3B4h}
  end;
end;


function getticks:longint;
var cnt,stp:longint;
    stat,x:word;
begin
  stat:=crtc+6;
  disable;
  stp:=200000;
  cnt:=0;

  while not VRetrace and (stp>0) do dec(stp);
  while VRetrace and (stp>0) do dec(stp);
  while not VRetrace and (stp>0) do dec(stp);

  if stp>0 then
    for x:=1 to 5 do
    begin
      while VRetrace and (cnt<1000000) do inc(cnt);
      while not VRetrace and (cnt<1000000) do inc(cnt);
    end;

  enable;
  getticks:=cnt;
end;


procedure progICD2061reg(clk:longint);
const
  ser_clk=4;
  ser_dta=8;
var
  old,dta,bit:word;
procedure setbits(bits:word);
begin
  outp($3C2,bits);
  for bits:=1 to 5 do;   {delay}
end;

begin
  if cv.chip=__S3 then  {Needs to enable the ICD for the STB Pegasus...}
  begin
    outpw(crtc,$4838);
    outpw(crtc,$A539);    {Enable S3 Ext}
    modinx(crtc,$42,$F,3);
  end;
  old:=inp($3CC);
  outpw(SEQ,$100);
  dta:=(old and $F3)+ser_dta;
  for bit:=1 to 6 do
  begin
    setbits(dta+ser_clk);
    setbits(dta);
  end;
  dta:=dta and $F3;
  setbits(dta);
  setbits(dta+ser_clk);
  setbits(dta);
  setbits(dta+ser_clk);

  for bit:=1 to 24 do
  begin
    dta:=dta and $F3;
    if (clk and 1)=0 then dta:=dta+ser_dta;
    setbits(dta+ser_clk);
    setbits(dta);
    dta:=dta xor ser_dta;
    setbits(dta);
    setbits(dta+ser_clk);
    clk:=clk shr 1;
  end;
  dta:=dta or ser_dta;
  setbits(dta+ser_clk);
  setbits(dta);
  setbits(dta+ser_clk);
  setbits(dta);
  outp($3C2,old);
  if cv.chip=__S3 then
  begin
    modinx(crtc,$5C,3,2);
    outpw(crtc,$5A39);    {Disable S3 Ext}
    outpw(crtc,$38);
  end;
  outpw(SEQ,$300);
  delay(15);
end;


const
  clkperm:integer=0;

function ClockPermission:boolean;
begin
  if clkperm=0 then
  begin
    settextmode;
    writeln('WHATVGA is about to test the clock chip or crystals on your');
    writeln('board. This can cause strange behavior on the display.');
    writeln('If your monitor is fixed-frequency (MDA, CGA, EGA or original');
    writeln('VGA, in fact anything that can''t handle at least 800x600) this');
    writeln('could in extreme situations potentionally hurt your monitor.');
    writeln('Press Y to continue clock testing, any other key to skip it:');
    if (getkey and $DF)=ord('Y') then clkperm:=1
                                 else clkperm:=2;
  end;
  ClockPermission:=clkperm=1;
end;

procedure findclocks;
var clks,x,y,divi,divid:word;
  basefreq,baselevel,l,l0,l1:longint;
  progcheck:boolean;    {Should we check for programmable clocks??}
begin
  if (inp($3CC) and 1)>0 then crtc:=$3D4 else crtc:=$3B4;
  progcheck:=true;
  clks:=4;
  case cv.clktype of
     clk_ext3:clks:=8;
     clk_ext4:clks:=16;
     clk_ext5:clks:=32;
     clk_ext6:clks:=64;
     clk_sdac:progcheck:=false;
  clk_TVP302x:begin
                progcheck:=false;
                clks:=0;
              end;
  end;

  if (clks>0) and ClockPermission then
  begin
    memmode:=_PL4;
    basefreq:=SetStdMode;   {Usually mode 12h, but...}
    y:=getclk(divi,divid);
    baselevel:=getticks;
    if baselevel>0 then
      for x:=0 to clks-1 do
      begin
        if (x=8) and (cv.chip=__compaq) and (cv.version>=CPQ_QV) then
           vio($32); {Hack to get at last 8 clock of QVision}
        setclk(x,divid);
        delay(50);   {Let clock settle}
        l:=getticks;
        if l>0 then cv.clks[x]:=((basefreq*baselevel) div l)*(divi div 12);
      end;
    setclk(y,divid);
  end;
  if progcheck and ClockPermission then
  begin
    outp($3C2,(inp($3CC) and $F3) or $8);   {Clk 2}
    delay(150);
    progICD2061reg($C00000);
    progICD2061reg($41A83C);  {14.318MHz* 2 * 109/62 = 50.35 MHz}
    l0:=getticks;
    progICD2061reg($41A8BC);  {14.318MHz* 2/2 * 109/62 = 25.175 MHz}
    l1:=getticks;

    if (l0<>0) and (abs(l1-l0*2)<25) then
    begin                    {Found an ICD2061}
      cv.clktype:=clk_ICD2061;
      progICD2061reg($C04000);  {Set prescale bit to *4}
      progICD2061reg($59A8BC);  {14.318MHz* 4/2 * 109/62 = 50.35 MHz}
      l:=getticks;
      if abs(l1-l*2)<25 then  {Prescale bit exists = ICD2061A}
        cv.clktype:=clk_ICD2061A;
      progICD2061reg($C00000);  {Restore ?}
    end;
    setclk(y,divid);
  end;

end;


procedure SelectVideo(item:word);
begin
  cv:=vid[item];
  loadmodes;
  video:=header[cv.chip];
  settextmode;
end;


procedure dac2pel;    {Force DAC back to PEL mode}
begin
  if inp($3c8)=0 then;
end;

function trigdac:word;  {Reads $3C6 4 times}
var x:word;
begin
  x:=inp($3c6);
  x:=inp($3c6);
  x:=inp($3c6);
  if (cv.dactype=_dacMU1880) then x:=inp($3C6);
  trigdac:=inp($3c6);
end;

procedure dac2comm;    {Enter command mode of HiColor DACs}
begin
  dac2pel;
  daccomm:=trigdac;
end;

function getdaccomm:word;
begin
  {if cv.DAC_RS2<>0 then getdaccomm:=inp($3C6+cv.DAC_RS2)
  else} begin
    dac2comm;
    getdaccomm:=inp($3C6);
    dac2pel;
  end;
end;

const
  SavedDACpage:word=0;  {DAC page state saved by SaveDACpage, reset by clearDACpage}

procedure SaveDACpage;
begin
  SavedDACpage:=0;   {default}
  if (cv.flags and FLG_ExtDAC)>0 then   {RS2/3 addressing ?}
    case cv.chip of
      __S3:begin
             outpw(crtc,$4838);  {Unlock S3 regs}
             outpw(crtc,$A539);
             SavedDACpage:=(rdinx(crtc,$43) and 2) shl 1;
             if (cv.version>S3_924) and (SavedDACpage=0) then
               SavedDACpage:=(rdinx(crtc,$55) and 3) shl 2;
             if (rdinx(crtc,$5C) and $20)>0 then inc(SavedDACpage,16);
             outpw(crtc,$5A39);
             outpw(crtc,$38);  {Lock S3 regs}
           end;
    end;
end;


const
  DACpage:boolean=false;  {Set if DAC registers enabled (MGA,Weitek..)}

  {Returns the address of the DAC register selected by index (0..3
   for standard DACs, 0..7 or 0..15 for advanced DACs), and sets
   any necessary flags. }
function setDACpage(index:word):word;
const
  DACadr:array[0..3] of word=($3C8,$3C9,$3C6,$3C7);
  M32DACadr:array[0..3] of word=($2EC,$2ED,$2EA,$2EB);
var ret,x:word;
    found:boolean;
begin
  found:=true;
  ret:=DACadr[index and 3];
  if cv.chip=__AGX then outp(cv.IOadr,1);   {Enable VGA regs}
  if (cv.flags and FLG_ExtDAC)>0 then   {RS2/3 addressing ?}
    case cv.chip of
       __AGX:begin
               if index>7 then ret:=cv.spcreg+(index and 3);
               if (index and 4)>0 then outp(cv.IOadr+10,$51)
                                  else outp(cv.IOadr+10,0);
             end;
       __ATI:if cv.Version<ATI_GUP_3 then found:=false
             else modinx(cv.IOadr,$A0,$60,index shl 3);
    __Compaq:begin
               if (index and 4)>0 then inc(ret,$8000);
               if (index and 8)>0 then inc(ret,$1000);
             end;
    __Mach32:begin
              { modinx(cv.IOadr,$A0,$60,index shl 3);}
               x:=inp($8EEF) and $CF;
               outp($7AEF,x+((index and $C) shl 2));
               ret:=ret-$DC;   {3C8 -> 2EC}
             end;
    __Mach64:begin
               outp($62EC,index shr 2);
               ret:=$5EEC+(index and 3);
             end;
       __MGA:begin
               if (not DACpage) and (cv.PCIid>0) then
               begin
                 wPCIlong($10,$AC000);  {Map ACC regs at AC000h}
                 cv.Xseg:=$AC00;
                 DACpage:=true;
               end;
               ret:=0;
             end;
       __NCR:ret:=ret+((index and 4) shl 13);    {A15 = $8000}
        __S3:begin
               outpw(crtc,$4838);  {Unlock S3 regs}
               outpw(crtc,$A539);
               if cv.version>S3_924 then
               begin
                 clrinx(crtc,$43,2);    {Just in case}
                 modinx(crtc,$55,3,index shr 2);
                 modinx(crtc,$5C,$20,index shl 1);   {TVP3025 control}
               end
               else modinx(crtc,$43,2,index shr 1);
               outpw(crtc,$5A39);
               outpw(crtc,$38);  {Lock S3 regs}
             end;
     __Tseng:begin
               outp($3BF,3);
               outp(crtc+4,$A0);
               modinx(crtc,$31,$40,index shl 4);   {Chrontel DAC}
             end;
            {Diamond Viper w/ OAK }
       __OAK:ret:=ret+(index and $C) shl 12;
    __Weitek,__WeitekP9:
             if (cv.version<WT_P9100) and (cv.PCIid=0) then
               ret:=ret+(index and $C) shl 12  {Non-PCI P9000s}
             else begin
               if not DACpage then
               begin
                 outp($9100,$41);
                 x:=inp($9104);
                 outp($9100,$41);
                 outp($9104,(x and $F3) or 4);   {Enable Acc regs at A000h}
                 DACpage:=true;
               end;
               ret:=0;
             end;
    else found:=false;
    end
  else found:=false;
  if not found and (index=dacHIcmd) then dac2comm;
  setDACpage:=ret;
end;

  {Clears any bits set by setDACpage. Should be used after a sequence
   of extended DAC register accesses to avoid problems with accessess
   to the standard DAC registers}
procedure clearDACpage;
var x:word;
begin
  if cv.chip=__AGX then outp(cv.IOadr,4);   {Disable VGA regs}
  if SavedDACpage>0 then
    x:=setDACpage(SavedDACpage)
  else begin
  if (cv.flags and FLG_ExtDAC)>0 then   {RS2/3 addressing ?}
    case cv.chip of
       __AGX:outp(cv.IOadr+10,0);
       __ATI:clrinx(cv.IOadr,$A0,$60);
    __Mach64:outp($62EC,0);
       __MGA:if DACpage then
               wPCIlong($10,PCIrec[cv.PCIid].l[4]);
        __S3:begin
               outpw(crtc,$4838);  {Unlock S3 regs}
               outpw(crtc,$A539);
               if cv.version>S3_924 then clrinx(crtc,$55,3);
               clrinx(crtc,$43,2);
               outpw(crtc,$5A39);
               outpw(crtc,$38);  {Lock S3 regs}
             end;
     __Tseng:begin
               outp($3BF,3);
               outp(crtc+4,$A0);
               clrinx(crtc,$31,$40);   {Chrontel DAC}
             end;
    __Weitek,__WeitekP9:
             if DACpage then
             begin
               outp($9100,$41);
               x:=inp($9104);
               outp($9100,$41);
               outp($9104,x and $F3);  {Disable Acc regs at A000h}
             end;
    else dac2pel;
    end
  else dac2pel;
  end;
  DACpage:=false;
end;



function rdDACreg(index:word):word;
var inx:word;
begin
  inx:=SetDACpage(index);
  if inx=0 then
    case cv.chip of
      __MGA:rdDACreg:=mem[cv.Xseg:$3C00+index*4];
      __Weitek,__WeitekP9:
            begin
              if mem[SegA000:$198]=0 then;    {Wait ?}
              rdDACreg:=mem[SegA000:$200+4*index];
            end;
    end
  else rdDACreg:=inp(inx);
end;

procedure wrDACreg(index,val:word);
var inx:word;
begin
  inx:=SetDACpage(index);
  if inx=0 then
    case cv.chip of
      __MGA:mem[cv.Xseg:$3C00+index*4]:=val;
      __Weitek,__WeitekP9:
            mem[SegA000:$200+4*index]:=val;
    end
  else outp(inx,val);
end;


procedure clrDACreg(index,val:word);
begin
  wrDACreg(index,rdDACreg(index) and not val);
end;

procedure setDACreg(index,val:word);
begin
  wrDACreg(index,rdDACreg(index) or val);
end;

procedure modDACreg(index,msk,val:word);
begin
  wrDACreg(index,(rdDACreg(index) and not msk) or (msk and val));
end;


function rgb(r,g,b:word):longint;
begin
  r:=lo(r);g:=lo(g);b:=lo(b);
  case memmode of
       _PL1,_PL1E,_CGA1:
            rgb:=r and 1;
       _PL2,_CGA2:
            rgb:=r and 3;
  _PL4,_PK4:rgb:=r and 15;
        _P8:rgb:=r;
       _P15:rgb:=((r shr 3) shl 5+(g shr 3)) shl 5+(b shr 3);
       _P16:rgb:=((r shr 3) shl 6+(g shr 2)) shl 5+(b shr 3);
  _P24,_P32:rgb:=(longint(r) shl 8+g) shl 8 +b;
_P24b,_P32b:rgb:=(longint(b) shl 8+g) shl 8 +r;
      _p32c:rgb:=((longint(r) shl 8+g) shl 8 +b) shl 8;
      _P32d:rgb:=((longint(b) shl 8+g) shl 8 +r) shl 8;
  end;
end;


  {Writes a 32bit value to a DWORD at offset ADR in Xseg}
procedure write32(adr:word;val:longint);
var w:word;
begin
  w:=cv.Xseg;
    {mov es,[cv.Xseg]  mov di,[BP+adr]  mov eax,[BP+val]  mov es:[di],eax}
  inline($8E/$46/<w/$8B/$7E/<adr/$66/$8B/$46/<val/$66/$26/$89/5);
end;

  {Writes a two 16bit values to a DWORD at offset ADR in Xseg as one MOVL}
procedure write32w(adr:word;hiw,low:word);
var w:word;
  l:longint;
begin
  l:=(longint(hiw) shl 16)+low;
  w:=cv.Xseg;
    {mov es,[cv.Xseg]  mov di,[BP+adr]  mov eax,[BP+l]  mov es:[di],eax}
  inline($8E/$46/<w/$8B/$7E/<adr/$66/$8B/$46/<l/$66/$26/$89/5);
end;