OS/2 Shareware BBS: SysTools/SysTools.zip/pci040vk.zip/pci.pas

Pascal/Delphi Source File | 2000-07-28 | 55KB | 2,133 lines

(*&Use32+*)
(*&Delphi-*)
(*&AlignCode+*)
(*&AlignData+*)
(*&AlignRec-*)
(*&Optimize+*)
Program PCI;

{$G+}
{$R+}
{$S+}
{$I+}


uses
  (*$IFDEF VirtualPascal*)
    VpSysLow,VpUtils,
    (*$IFDEF DPMI32*)
    DPMI32,DPMI32df,
    (*$ENDIF*)
    (*$IFDEF OS2*)
    Os2Base,Os2Def,
    (*$ENDIF*)
  (*$ELSE*)
    newdelay,
  (*$ENDIF*)
  Dos,Crt;


{$I classes.pas}


{
  This code is Written by Craig Hart in 1996-2000. It is released as freeware;
  please use and modify at will. No gurarantees are made or implied.


  Please read the accompaning documentation PCI.DOC for all the info
  relating to this program!
}


const
  revision      : string[5-1+2]='0.40vk'; (* 0.40ß *)

(*$IFDEF VirtualPascal*)
type
  PWord=^smallword;
(*$ELSE*)
type
  smallword=word;
(*$ENDIF*)


var
  wrlncount,
  PCIverhi,
  PCIverlo,
  PCIchar,
  PCI_hibus,
  errcode,
  deviceid,
  func,
  info,
  nn,
  pp,
  lb,
  bus,
  sum,
  disp,
  cap_ptr       : byte;

  showhelp,
  businfo,
  tableok,
  dorouting,
  dopcirouting,
  userev,
  summary,
  bogusid,
  genssid,
  dumpregs,
  usebios,
  failed,
  first         : boolean;


  irqmap        : array[0..15] of byte;

  conmap,
  len,
  addr,
  index,
  i,
  j,
  l,
  v             : word;

  f             : text;

  revchk,
  oemidnum,
  oemidstr,
  cmdstr,
  vstr,
  cmpstr        : string;


  infotbl       : array[0..$ff] of byte;

  irqbuff       : array[0..1023] of byte;


  pcidevs_txt   : string;
  pcidevs_path  : string;


  linecounter   :word;

  org_output_FlushFunc  : pointer;


(*$IFDEF VirtualPascal*)
procedure pagefilter1(var t:text);(*$Saves ALL*)
  var
     z:word;
  begin
    with TextRec(t) do
      for z:=1 to BufPos do
        if BufPtr^[z]=#10 then
          Inc(linecounter);
  end;

procedure pagefilter2;(*$Saves ALL*)
  begin
    if linecounter>=Hi(WindMax) then
      begin
        SysReadKey;
        linecounter:=0;
      end;
  end;

procedure page_output_FlushFunc;assembler;(*$Uses None*)(*$Frame-*)
  asm
    push ebx
    call pagefilter1
    push ebx
    call [org_output_FlushFunc]
    call pagefilter2
    ret 4
  end;

(*$ELSE*) (* BP *)

procedure pagefilter1(var t:text);assembler;
  asm
    push ax
      push di
        push es
          push cx

            les di,[t]
            mov cx,es:[di+TextRec.BufPos]
            les di,es:[di+TextRec.BufPtr]
            cld
            mov al,10
  @sl:
            jcxz @ret
            dec cx
            scasb
            jne @sl
            inc linecounter
            jmp @sl
  @ret:
          pop cx
        pop es
      pop di
    pop ax
  end;

procedure pagefilter2;assembler;
  asm
    push ax
      mov ax,WindMax
      shr ax,8
      cmp linecounter,ax
      jb @ret

      sub ax,ax
      int $16

      mov linecounter,0
  @ret:
    pop ax
  end;

procedure page_output_FlushFunc;assembler;
  asm
    push es
    push bx
    call pagefilter1
    push es
    push bx
    call [org_output_FlushFunc]
    call pagefilter2
    retf 4
  end;
(*$ENDIF*)

function cvtb(b:byte) : byte;
begin
  if b>9 then cvtb:=b+Ord('A')-10 else cvtb:=b+Ord('0');
end;

function wrhexb(byt:byte): string;
begin
 wrhexb:=Chr(cvtb(byt and $0f));
end;

function wrhex(byt:byte) : string;
begin
  wrhex:=Chr(cvtb((byt and $f0) shr 4))+Chr(cvtb(byt and $0f));
end;

function wrhexw(wor:word): string;
begin
  wrhexw:=Chr(cvtb(wor shr 12))+Chr(cvtb((wor shr 8) and $f))+Chr(cvtb((wor shr 4) and $f))+Chr(cvtb(wor and $f));
end;


(* Make the PCI configuration status register printout pretty *)
(* Input = the string to be output *)

Procedure printstatus (s : string);
Begin
  if not first then if (Length(s)+WhereX)>78 then
  begin
    WriteLn(',');
    Write('   ');
  end else Write(', ');
  Write(s);
  first:=false;
End;


(*$IFDEF VirtualPascal*)
function IORedirected : boolean ;
  begin
    IORedirected:=not VPUtils.IsFileHandleConsole(SysFileStdOut);
  end;
(*$ELSE*)
function IORedirected : boolean ; Assembler;
asm
  push ds
  mov ax,prefixseg
  mov ds,ax
  xor bx,bx
  les bx,[bx + $34]
  mov al,es:[bx]
  mov ah,es:[bx +1]
  pop ds
  cmp al,ah
  mov al,true
  jne @exit

  mov al,false

 @exit:
end;
(*$ENDIF*)


(*$IFDEF OS2*)
var
  biosf000:array[0..$ffff] of byte;

procedure os2_read_bios;

  var
    hand,
    action,
    rc                  :longint;

    ParmRec1:
      record            // Input parameter record
        phys32          :longint;
        laenge          :smallword;
      end;

    ParmRec2:
      record
        sel             :smallword;
      end;

    ParmLen             : ULong;  // Parameter length in bytes
    DataLen             : ULong;  // Data length in bytes
    Data1:
      record
        sel             :smallword;
      end;

  begin
    FillChar(biosf000,SizeOf(biosf000),0);

    if DosOpen('SCREEN$',hand,action,0,0,1,$40,nil)<>0 then
      exit;

    ParmLen:=SizeOf(ParmRec1);

    with ParmRec1 do
      begin
        phys32:=$000f0000;
        laenge:=0;
      end;

    datalen:=SizeOf(data1);
    rc:=DosDevIOCtl(
            hand,                       // Handle to device
            IOCTL_SCR_AND_PTRDRAW,      // Category of request
            SCR_ALLOCLDT,               // Function being requested
            @ParmRec1,                  // Input/Output parameter list
            ParmLen,                    // Maximum output parameter size
            @ParmLen,                   // Input:  size of parameter list
                                        // Output: size of parameters returned
            @Data1,                     // Input/Output data area
            Datalen,                    // Maximum output data size
            @DataLen);                  // Input:  size of input data area
    if rc=0 then
      begin

        asm (*$SAVES NONE*)
          push gs

            sub esi,esi
            mov gs,data1.sel

            mov edi,offset biosf000
            mov ecx,$10000
            cld
          @l1:
            mov al,gs:[esi]
            inc esi
            stosb
            loop @l1

          pop gs
        end;

        ParmLen:=SizeOf(ParmRec2);

        with ParmRec2 do
          begin
            sel:=data1.sel;
          end;

        DataLen:=0;
        rc:=DosDevIOCtl(
                hand,                           // Handle to device
                IOCTL_SCR_AND_PTRDRAW,          // Category of request
                SCR_DEALLOCLDT,                 // Function being requested
                @ParmRec2,                      // Input/Output parameter list
                ParmLen,                        // Maximum output parameter size
                @ParmLen,                       // Input:  size of parameter list
                                                // Output: size of parameters returned
                nil,                            // Input/Output data area
                Datalen,                        // Maximum output data size
                @DataLen);                      // Input:  size of input data area

      end;

    DosClose(hand);
  end;

(*$ENDIF*)

function Mem_F000(const i:word):byte;
  begin
    (*$IFDEF VirtualPascal*)

      (*$IFDEF DPMI32*)
      Mem_F000:=Mem[$f0000+i];
      (*$ENDIF*)

      (*$IFDEF OS2*)
      Mem_F000:=biosf000[i];
      (*$ENDIF*)


    (*$ELSE*)
    Mem_F000:=Mem[$f000:i];
    (*$ENDIF*)
  end;

function MemW_F000(const i:word):word;
  begin
    (*$IFDEF VirtualPascal*)

      (*$IFDEF DPMI32*)
      MemW_F000:=MemW[$f0000+i];
      (*$ENDIF*)

      (*$IFDEF OS2*)
      MemW_F000:=PWord(@biosf000[i])^;
      (*$ENDIF*)


    (*$ELSE*)
    MemW_F000:=MemW[$f000:i];
    (*$ENDIF*)
  end;

function MemL_F000(const i:word):longint;
  begin
    (*$IFDEF VirtualPascal*)

      (*$IFDEF DPMI32*)
      MemL_F000:=MemL[$f0000+i];
      (*$ENDIF*)

      (*$IFDEF OS2*)
      MemL_F000:=PLongint(@biosf000[i])^;
      (*$ENDIF*)


    (*$ELSE*)
    MemL_F000:=MemL[$f000:i];
    (*$ENDIF*)
  end;

(*$IFDEF OS2*)
var
  oemhlp_handle :longint;

procedure open_oemhlp;
  begin
    if SysFileOpen('OEMHLP$',open_access_readonly+open_share_denynone,oemhlp_handle)<>0 then
       oemhlp_handle:=-1;
  end;

procedure close_oemhlp;
  begin
    SysFileClose(oemhlp_handle);
  end;
(*$ENDIF*)

(*$IFDEF VirtualPascal*)

  (*$IFDEF OS2*)
  function lookup_bios(deviceid,func,bus:byte;index:word) : byte;

    var
      para              :
        packed record
          subfuction    :byte;
          busnumber     :byte;
          devfuncnumber :byte;
          configregister:byte;
          size          :byte;
        end;

      data              :
        packed record
          returncode    :byte;
          data          :longint;
        end;

      para_len,data_len :longint;


    begin
      with para do
        begin
          subfuction:=3; (* read configuartion byte ($1a/$b108) *)
          busnumber:=bus;
          devfuncnumber:=deviceid shl 3+func;
          configregister:=index;
          size:=SizeOf(byte);
        end;
      para_len:=SizeOf(para);

      with data do
        begin
          returncode:=0;
          data:=0;
        end;
      data_len:=SizeOf(data);

      errcode:=
        DosDevIoCtl(
          oemhlp_handle,
          $80,              (* oemhlp/testcfg/.. *)
          $0b,              (* PCI *)
          @para,SizeOf(para),@para_len,
          @data,SizeOf(data),@data_len);

      if errcode=$00 then
        begin
          failed:=false;
          lookup_bios:=Lo(data.data);
        end;
    end;

  procedure pci_present_test;
    var
      para              :
        packed record
          subfuction    :byte;
        end;

      data              :
        packed record
          returncode    :byte;
          hardwaremech  :byte;
          majorver      :byte;
          minorver      :byte;
          lastbus       :byte;
        end;

      para_len,data_len :longint;


    begin
      with para do
        begin
          subfuction:=0; (* read configuartion byte ($1a/$b101) *)
        end;
      para_len:=SizeOf(para);

      FillChar(data,SizeOf(data),0);
      data_len:=SizeOf(data);

      errcode:=
        DosDevIoCtl(
          oemhlp_handle,
          $80,              (* oemhlp/testcfg/.. *)
          $0b,              (* PCI *)
          @para,SizeOf(para),@para_len,
          @data,SizeOf(data),@data_len);

      if errcode=$00 then
        with data do
          begin
            PCIchar:=hardwaremech;
            PCI_hibus:=lastbus;
            PCIverlo:=minorver;
            PCIverhi:=majorver;
            failed:=false;
          end;
    end;


  procedure load_irqbuff;
    begin
      (* failed:=true; *)
    end;

  (*$ENDIF OS2*)

  (*$IFDEF DPMI32*)
  function lookup_bios(deviceid,func,bus:byte;index:word) : byte;assembler;
    (*$Uses EBX,ECX,EDX,EDI*)(*$Frame-*)
    asm
      mov ax,$b108
      mov bl,deviceid
      shl bl,3
      add bl,func
      mov bh,bus
      mov edi,index
      int $1a
      jc @exit

      mov failed,false
    @exit:
      mov errcode,ah
      mov al,cl
    end;


  procedure pci_present_test;assembler;
    (*$Uses ALL*)(*$Frame-*)
    asm
      mov ax,$b101
      int $1a
      jc @exit

      cmp dx,$4350
      jne @exit

      mov PCIchar,al
      mov PCI_hibus,cl
      mov PCIverlo,bl
      mov PCIverhi,bh
      mov failed,false

    @exit:
    end;

  procedure load_irqbuff;
    var
      irq16     :smallword;
      r         :real_mode_call_structure_typ;
    begin
      if GetDosMem(irq16,SizeOf(irqbuff))<>0 then Exit;
      FillChar(Mem[irq16 shl 4],SizeOf(irqbuff),0);

      MemW[irq16 shl 4+0]:=SizeOf(irqbuff)-6;
      MemW[irq16 shl 4+2]:=6;
      MemW[irq16 shl 4+4]:=irq16;

      with r do
        begin
          init_register(r);
          ax_:=$b10e;
          bx_:=$0000;
          ds_:=$f000;
          es_:=irq16;
          edi_:=0;

          intr_realmode(r,$1a);
          Move(Ptr(irq16 shl 4)^,irqbuff,SizeOf(irqbuff));
          len:=MemW[es_ shl 4+edi_];
          freedosmem(irq16);

          if ah_<>0 then Exit;

          conmap:=bx_;
          failed:=false;

        end;
    end;
  (*$ENDIF DPMI32*)

  function lookup_hw(deviceid,func,bus:byte;index:word) : byte;assembler;
    (*$Uses ECX*)(*$Frame+*)
    asm
      mov ah,$80
      mov al,bus
      shl eax,16
      mov al,byte ptr[index]
      and al,$fc
      mov ah,deviceid
      shl ah,3
      add ah,func

      push eax
      push $0cf8
      call _Out32

      mov ecx,index
      and ecx,3
      shl ecx,3 (* *8  *)

      push $0cfc
      call _In32
      shr eax,cl
      mov cl,al
      mov failed,false

      push 0
      push $0cf8
      call _Out32

      mov al,cl
    end;


(*$ELSE*) (* BP 7.0 *)
function lookup_bios(deviceid,func,bus:byte;index:word) : byte;

var inf:byte;

begin
  asm
    mov ax,$b108
    mov bl,deviceid
    shl bl,3
    add bl,func
    mov bh,bus
    mov di,index
    int $1a
    jc @exit

    mov failed,false
    mov inf,cl
  @exit:
    mov errcode,ah
  end;
  lookup_bios:=inf;
end;


function lookup_hw(deviceid,func,bus:byte;index:word) : byte;
var inf:byte;

begin
  asm
    mov ax,$8000
    mov al,bus
    db $66;shl ax,16

    mov ax,index
    and ax,00fch
    mov ah,deviceid
    shl ah,3
    add ah,func

    mov dx,0cf8h
    db $66;out dx,ax

    mov ax,index
    and ax,3
    mov bl,8
    mul bl
    mov cx,ax

    mov dx,0cfch
    db $66;in ax,dx
    db $66;shr ax,cl
    mov inf,al
    mov failed,false


    db $66;xor ax,ax
    mov dx,0cf8h
    db $66;out dx,ax

  end;
  lookup_hw:=inf;
end;

procedure pci_present_test;assembler;
  asm
    mov ax,$b101
    int $1a
    jc @exit

    cmp dx,$4350
    jne @exit

    mov PCIchar,al
    mov PCI_hibus,cl
    mov PCIverlo,bl
    mov PCIverhi,bh
    mov failed,false

  @exit:
  end;

procedure load_irqbuff;assembler;
  const
    irq_buf_size=SizeOf(irqbuff)-2-4;
  asm
    push ds

    mov bx,0
    mov ax,seg irqbuff
    mov es,ax
    mov di,offset irqbuff
    mov word ptr es:[di+0],irq_buf_size
    lea ax,[di+6]
    mov es:[di+2],ax
    mov es:[di+4],es

    mov ax,0f000h
    mov ds,ax
    mov ax,0b10eh

    int $1a
    pop ds

    mov cx,word ptr es:[di]

    cmp ah,0
    jne @exit


    mov conmap,bx
    mov len,cx
    mov failed,false

  @exit:
  end;
(*$ENDIF*)


(*$IFDEF VirtualPascal*)
var
  pcidevs_txt_buffer    :PChar;
  pcidevs_txt_end       :PChar;
  pcidevs_txt_position  :PChar;
(*$ENDIF*)

procedure Assign2(var f:text;const filename:string);
  (*$IFDEF VirtualPascal*)
  var
    f2                  :file;
    f2s                 :longint;

  begin
    pcidevs_txt_buffer  :=nil;
    pcidevs_txt_end     :=nil;
    pcidevs_txt_position:=nil;

    Assign(f2,filename);
    (*$I-*)
    Reset(f2,1);
    (*$I+*)
    if InOutRes<>0 then Exit;

    f2s:=FileSize(f2);
    GetMem(pcidevs_txt_buffer,f2s+2);
    pcidevs_txt_buffer[f2s  ]:=#$0d;
    pcidevs_txt_buffer[f2s+1]:=#$0a;
    BlockRead(f2,pcidevs_txt_buffer[0],f2s);
    Close(f2);

    pcidevs_txt_end     :=@pcidevs_txt_buffer[f2s];
    pcidevs_txt_position:=pcidevs_txt_buffer;
  end;
  (*$ELSE*)
  begin
    Assign(f,filename);
  end;
  (*$ENDIF*)

procedure Reset2(var f:text);
  (*$IFDEF VirtualPascal*)
  begin
    pcidevs_txt_position:=pcidevs_txt_buffer;
  end;
  (*$ELSE*)
  begin
    Reset(f);
  end;
  (*$ENDIF*)


procedure ReadLn2(var f:text;var zk:string);
  (*$IFDEF VirtualPascal*)
  begin
    zk:='';
    repeat
      case pcidevs_txt_position[0] of
        ^Z,
        #$0d:
          Inc(pcidevs_txt_position);
        #$0a:
          begin
            Inc(pcidevs_txt_position);
            Exit;
          end;
      else
        zk:=zk+pcidevs_txt_position[0];
        Inc(pcidevs_txt_position);
      end;
    until false;
  end;
  (*$ELSE*)
  begin
    ReadLn(f,zk);
  end;
  (*$ENDIF*)


function Eof2(var f:text):boolean;
  (*$IFDEF VirtualPascal*)
  begin
    Eof2:=(pcidevs_txt_position=pcidevs_txt_end);
  end;
  (*$ELSE*)
  begin
    Eof2:=Eof(f);
  end;
  (*$ENDIF*)


procedure Close2(var f:text);
  (*$IFDEF VirtualPascal*)
  begin
  end;
  (*$ELSE*)
  begin
    Close(f);
  end;
  (*$ENDIF*)



procedure listmap(va:word;dispst:string);
var
  comma  : byte;
  failed : boolean;
  l,
  j      : word;

begin
  failed:=true;
  Write(dispst);
  comma:=0;
  for l:=0 to 15 do if (va and (1 shl l))>0 then Inc(comma);

  l:=1;
  j:=0;
  repeat
    if (va and l)=l then
    begin
      Write(j);
      if comma>1 then Write(',') else Write(' ');
      Dec(comma);
      failed:=false;
    end;
    l:=l shl 1;
    Inc(j);
  until j=16;
  if failed then WriteLn('None') else WriteLn;
end;


procedure lookupven(silent:boolean);
begin
  Reset2(f);
  failed:=true;
  repeat
    ReadLn2(f,vstr);
    if (vstr[1]='V') and (Copy(vstr,3,4)=cmpstr) then
    begin
      TextColor(14);
      if not silent then Write(Copy(vstr,8,Length(vstr)));
      TextColor(7);
      failed:=false;
    end;
  until Eof2(f) or not failed;
  if failed then
  begin
    TextColor(12);
    if not silent then Write('Unknown');
    TextColor(7);
  end;
end;

procedure lookupdev;
begin
  failed:=true;
  if not Eof2(f) then
  begin
    repeat
      ReadLn2(f,vstr);
      if (vstr[1]='D') and (Copy(vstr,3,4)=cmpstr) then
      begin
        if not Eof2(f) then ReadLn2(f,revchk);
        if revchk[1]='R' then
        begin
          repeat
            if wrhex(infotbl[8])=Copy(revchk,3,2) then vstr:='xxxxxxx'+Copy(revchk,6,Length(revchk));
            if not Eof2(f) then ReadLn2(f,revchk);
          until revchk[1]<>'R';
        end;
        TextColor(14);
        Write(Copy(vstr,8,Length(vstr)));
        failed:=false;
        TextColor(7);
      end;
    until Eof2(f) or not failed or (vstr[1]='V');
  end;
  if failed then
  begin
    TextColor(12);
    Write('Unknown');
    TextColor(7);
  end;
end;


begin
  (*$IFDEF OS2*)
  open_oemhlp;
  os2_read_bios;
  (*$ENDIF*)

  showhelp:=false;
  businfo:=false;
  dorouting:=true;
  dopcirouting:=false;
  dumpregs:=false;
  usebios:=true;
  summary:=false;

{ the following hack permits MS-DOS display output redirection to work }
  if ioredirected then
    begin
      WriteLn('Craig Hart''s PCI+AGP bus sniffer, version ',revision,', freeware made in 1996-2000.');
      Assign(output,'');
      Rewrite(output);
    end
  else
    begin
       ClrScr;
       linecounter:=0;
       { insert page filter }
       with TextRec(Output) do
         begin
           org_output_FlushFunc:=FlushFunc;
           FlushFunc:=@page_output_FlushFunc;
         end;
    end;



  for i:=0 to 15 do irqmap[i]:=0;
  failed:=true;

  { calculate datafile searchpath: exefile path,... }
  pcidevs_path:=ParamStr(0);
  while (not (pcidevs_path[Length(pcidevs_path)] in ['\','/'])) and (pcidevs_path<>'') do
    Dec(pcidevs_path[0]);

  pcidevs_path:=pcidevs_path+';'+GetEnv('PATH')+';'+GetEnv('DPATH');

  pcidevs_txt:=FSearch('pcidevs.txt',pcidevs_path);

  {$i-}
  if pcidevs_txt<>'' then
    begin
      Assign2(f,pcidevs_txt);
      Reset2(f);
    end;

  if (IOResult<>0) or (pcidevs_txt='') then
  begin
    WriteLn('PCI Halted:');
    WriteLn;
    WriteLn('Sorry, I cannot locate my PCIDEVS.TXT datafile!!!');
    Halt(10);
  end;
  Close2(f);
  {$i+}



  if ParamCount>0 then
  begin
    for i:=1 to ParamCount do
    begin
      cmdstr:=ParamStr(i);
      for j:=1 to Length(cmdstr) do cmdstr[j]:=UpCase(cmdstr[j]);
      if (Length(cmdstr)=Length('-?')) and (cmdstr[1] in ['+','-','/']) then
        case cmdstr[2] of
          'H':usebios:=false;
          'D':dumpregs:=true;
          'S':summary:=true;
          'T':dorouting:=false;
          'P':dopcirouting:=true;
          'B':businfo:=true;
        else
              showhelp:=true;
        end
      else
        showhelp:=true;

      if showhelp then
      begin
        TextMode(Co80);
        linecounter:=0;
        WriteLn(' Help for PCI  (Version ',revision,')');
        TextColor(8);
        WriteLn('───────────────────────────────');
        TextColor(7);
        WriteLn;
        WriteLn('Usage: PCI [-H] [-D] [-S] [-T] [-B] [-P] [-?]   [] indicates optional parameter');
        WriteLn;
        WriteLn;
        WriteLn('-H : Use direct hardware access (instead of the BIOS) to retrieve PCI Info');
        WriteLn('     May be required for accurate reporting on Intel 430FX chipset+Award BIOS');
        WriteLn('-D : Do a hex-dump of each device''s configuration space');
        WriteLn('-S : Create a brief, summary report only; only devices and IRQs listed');
        WriteLn('-T : Disable test ROM IRQ Routing Table function');
        WriteLn('-B : Enable display of Bus, Device & Function info');
        WriteLn('-P : Enable display of PCI slot routing data');
        WriteLn('-? : Displays this help screen!');
        WriteLn;
        WriteLn;
        WriteLn('PCI Supports generating reports to a file or printer using MS-DOS pipes; i.e.');
        WriteLn;
        WriteLn('      PCI -D > REPORT.TXT             PCI > LPT1:           PCI | MORE');
        WriteLn;
        WriteLn('PCI is written by Craig Hart, and is released as freeware, with no restictions');
        Write('on use or copying. Visit ');
        TextColor(11);
        Write('http://members.hyperlink.net.au/~chart ');
        TextColor(7);
        WriteLn('for updates to');
        WriteLn('the program and the PCI Database file PCIDEVS.TXT');
        Halt(10);
      end;
    end;
  end;


  if test8086<2 then
  begin
    WriteLn('PCI Halted:');
    WriteLn;
    WriteLn('PC Must be at least a 386 to possibly have a PCI or AGP bus!');
    Halt(1);
  end;

{ Look for PCI BIOS }
  pci_present_test;



  if failed then
  begin
    WriteLn('PCI Halted:');
    WriteLn;
    WriteLn('No PCI BIOS was detected! (NB: This always fails under Windows NT!)');
    Halt(2);
  end;


{ OK, we have PCI... do our stuff.. }


  begin
    if not ioredirected then TextMode(Co80+Font8x8);
    linecounter:=0;
    WriteLn(' Craig Hart''s PCI+AGP bus sniffer, version ',revision,', freeware made in 1996-2000.');
    WriteLn;
    Write('PCI BIOS Version ',PCIverhi,'.',wrhex(PCIverlo),' found!');

    if summary then WriteLn('                                  (Summary Report)') else WriteLn;

    WriteLn;
    WriteLn('Number of PCI Busses : ',PCI_hibus+1);
    Write('PCI Characteristics  : ');
    if PCIchar and 1=1 then Write('Config Mechanism 1 ') else usebios:=true; { must use BIOS if no cfg mech 1 supported }
    if PCIchar and 2=2 then Write('Config Mechanism 2 ');
    if PCIchar and 16=16 then Write('Special Cycle Mechanism 1 ');
    if PCIchar and 32=32 then Write('Special Cycle Mechanism 2 ');
    WriteLn;
    WriteLn;
    Write('Searching for PCI Devices using ');
    if usebios then WriteLn('the System BIOS') else WriteLn('Configuration Mechanism 1');
    WriteLn;

    for bus:=0 to pci_hibus do          { fix bugs for 440LX chipset, 2 PCI busesAGP=1 bus! }
    begin
    for deviceid:=0 to $1f do
    begin
      for func:=0 to 7 do
      begin
        index:=0;
        repeat
          if usebios then info:=lookup_bios(deviceid,func,bus,index) else info:=lookup_hw(deviceid,func,bus,index);
          infotbl[index]:=info;
          Inc(index);
{ don't try to read cfg-space of non-existant devices: hangs some chipsets!}
          if index=2 then if (infotbl[0]=$ff) and (infotbl[1]=$ff) then index:=$100;
        until index=$100;



        if (infotbl[0]<>$ff) or (infotbl[1]<>$ff) then
        begin
          if businfo then
          begin
            Write(' PCI Bus ');
            TextColor(11);
            Write(bus);
            TextColor(7);
            Write(', Device Number ');
            TextColor(11);
            Write(deviceid);
            TextColor(7);
            Write(', Device Function ');
            TextColor(11);
            WriteLn(func);
            TextColor(7);
          end;

          Write(' Vendor ',wrhexw(infotbl[1] shl 8+infotbl[0]),'h ');
          cmpstr:=wrhexw(infotbl[1] shl 8+infotbl[0]);
          lookupven(false);
          WriteLn;


          Write(' Device ',wrhexw(infotbl[3] shl 8+infotbl[2]),'h ');
          cmpstr:=wrhexw(infotbl[3] shl 8+infotbl[2]);
          lookupdev;
          WriteLn;


          if not summary then
          begin
            Write(' Command ',wrhexw(infotbl[5] shl 8+infotbl[4]),'h');
            if infotbl[5] shl 8+infotbl[4] > 0 then
            begin
              first:=true;
              Write(' (');
              if infotbl[4] and 1=1 then printstatus('I/O Access');
              if infotbl[4] and 2=2 then printstatus('Memory Access');
              if infotbl[4] and 4=4 then printstatus('BusMaster');
              if infotbl[4] and 8=8 then printstatus('Special Cycles');
              if infotbl[4] and 16=16 then printstatus('MemWrite+Invalidate');
              if infotbl[4] and 32=32 then printstatus('VGA Palette Snoop');
              if infotbl[4] and 64=64 then printstatus('Parity Error Response');
              if infotbl[4] and 128=128 then printstatus('Wait Cycles');

              if infotbl[5] and 1=1 then printstatus('System Errors');
              if infotbl[5] and 2=2 then printstatus('Back-To-Back Transactions');

              Write(')');
            end;
            WriteLn;


            Write(' Status ',wrhexw(infotbl[7] shl 8+infotbl[6]),'h');
            if (infotbl[6]<>0) or (infotbl[7]<>0) then
            begin
              first:=true;
              Write(' (');
              if infotbl[6] and 16=16 then printstatus('Has Capabilities List');
              if infotbl[6] and 32=32 then printstatus('Supports 66MHz');
              if infotbl[6] and 64=64 then printstatus('Has UDF');
              if infotbl[6] and 128=128 then printstatus('Supports Back-To-Back Trans.');

              if infotbl[7] and 1=1 then printstatus('Data parity Error Detected');
              if infotbl[7] and 8=8 then printstatus('Signalled Target Abort');
              if infotbl[7] and 16=16 then printstatus('Received Target Abort');
              if infotbl[7] and 32=32 then printstatus('Received Master Abort');
              if infotbl[7] and 64=64 then printstatus('Signalled System Error');
              if infotbl[7] and 128=128 then printstatus('Detected Parity Error');

              case ((infotbl[7] and 6) shr 1) of
                0 : printstatus('Fast Timing');
                1 : printstatus('Medium Timing');
                2 : printstatus('Slow Timing');
                3 : printstatus('Unknown Timing');
              end;
              Write(')');

            end;
            WriteLn;

            Write(' Revision ',wrhex(infotbl[8]),'h');
            Write(', Header Type ',wrhex(infotbl[$e]),'h');
            WriteLn(', Bus Latency ',wrhex(infotbl[$d]),'h');


            Write(' Self test ',wrhex(infotbl[$f]),'h (Self test ');
            if infotbl[$f] and $80=0 then Write('not ');
            Write('supported');


            if infotbl[$f] and $80=$80 then
            begin
              Write(': Completion code ',wrhexb(infotbl[$f] and $f),'h - ');
              if infotbl[$f] and $f=0 then
              begin
                TextColor(10);
                Write('OK');
                TextColor(7);
              end else
              begin
                TextColor(12);
                Write('Failed!!');
                TextColor(7);
              end;
            end;



            WriteLn(')');


            if infotbl[$c]<>0 then WriteLn(' Cache line size ',infotbl[$c]*4,' Bytes (',infotbl[$c],' DWords)');


            Write(' PCI Class ');
            for i:=0 to high_class_name do
            if infotbl[$b]=i then
            begin
              TextColor(14);
              Write(PCI_class_names[i]);
              TextColor(7);
            end;

            Write(' Subclass ');
            for i:=0 to high_class_array do
            if (infotbl[$b] shl 8 + infotbl[$a])=PCI_class_array[i].class then
            begin
              TextColor(14);
              Write(PCI_class_array[i].name);
              TextColor(7);
            end;

            Write(' Interface ');
            WriteLn(wrhex(infotbl[9]),'h');

          end;



          if not summary then
          begin
{ look for generic PCI IDE controller & decode it's info, if present }
           if (infotbl[$b]=01) and (infotbl[$a]=01) then
           begin
             WriteLn(' PCI EIDE Controller Features :');
             Write('  BusMaster EIDE is ');
             if infotbl[$9] and $80=0 then
             begin
               TextColor(12);
               Write('NOT ');
               TextColor(7);
             end;
             WriteLn('supported');

             Write('  Primary   Channel is ');
             if infotbl[$9] and 1=0 then
             begin
               WriteLn('at I/O Port 01F0h and IRQ 14');
               Inc(irqmap[14]);
             end else WriteLn('in native mode at Addresses 0 & 1');
             Write('  Secondary Channel is ');
             if infotbl[$9] and 4=0 then
             begin
               WriteLn('at I/O Port 0170h and IRQ 15');
               Inc(irqmap[15]);
             end else WriteLn('in native mode at Addresses 2 & 3');
           end;

           end else
           begin
{ summary mode: pick up IRQs only }
             if (infotbl[$b]=01) and (infotbl[$a]=01) then
             begin
               if infotbl[$9] and 1=0 then Inc(irqmap[14]);
               if infotbl[$9] and 4=0 then Inc(irqmap[15]);
             end;
           end;




{ if type 0 table & if Subsystem ID exists, display and scan file for match }
           if infotbl[$e] and $7f=0 then
           if (infotbl[$2c]<>0) or (infotbl[$2d]<>0) or (infotbl[$2e]<>0) or (infotbl[$2f]<>0) then
           begin

{ subsystem ID }

             Write(' Subsystem ID ',wrhexw(infotbl[$2f] shl 8+infotbl[$2e]));
             Write(wrhexw(infotbl[$2d] shl 8+infotbl[$2c]),'h');
             cmpstr:=wrhexw(infotbl[$2f] shl 8+infotbl[$2e])+wrhexw(infotbl[$2d] shl 8+infotbl[$2c]);


             genssid:=false;
             if (infotbl[$2c]=infotbl[0])
             and (infotbl[$2d]=infotbl[1])
             and (infotbl[$2e]=infotbl[2])
             and (infotbl[$2f]=infotbl[3]) then genssid:=true;

             oemidnum:='';
             oemidstr:='';
             bogusid:=false;


             failed:=true;
             userev:=true;
             if not Eof2(f) then
             begin
               repeat
{!!}             if userev then vstr:=revchk else ReadLn2(f,vstr);
                 userev:=false;


{ OEM Vendor ID }
                 if vstr[1]='O' then
                 begin
                   if Copy(vstr,3,4)=Copy(cmpstr,5,4) then
                   begin
                     oemidstr:=Copy(vstr,8,Length(vstr)); { closest match }
                     oemidnum:=Copy(vstr,3,4); { matching vendor name }
                   end;
                 end;


                 if vstr[1]='S' then
                 begin
                   if Copy(vstr,3,4)=Copy(cmpstr,1,4) then
                   begin
                     if oemidnum<>'' then
                     begin
                       oemidstr:=Copy(vstr,8,Length(vstr));
                       begin
                         TextColor(14);
                         Write(' ',oemidstr);
                         if genssid then
                         begin
                           TextColor(11);
                           WriteLn(' (Generic ID)')
                         end else WriteLn;
                         failed:=false;
                         TextColor(7);
                       end;
                     end;
                   end;
                 end;







{ Oddball 8 digit entry }
                 if (vstr[1]='X') and (Copy(vstr,3,8)=cmpstr) then
                 begin
                   oemidnum:=Copy(vstr,7,4); { matching vendor name }
                   bogusid:=true;
                   TextColor(14);
                   Write(' ',Copy(vstr,12,Length(vstr)));
                   if genssid then
                   begin
                     TextColor(11);
                     WriteLn(' (Generic ID)')
                   end else WriteLn;
                   failed:=false;
                   TextColor(7);
                 end;



               until Eof2(f) or not failed or ((vstr[1]<>'O') and (vstr[1]<>'X') and (vstr[1]<>'S'));
             end;






             if failed then
             begin
               if oemidstr<>'' then
               begin
                 TextColor(14);
                 Write(' ',oemidstr);
                 TextColor(15);
                 Write(' (Guess Only!)');
                 TextColor(7);
               end else
               begin
                 TextColor(12);
                 Write(' Unknown');
               end;

               if genssid then
               begin
                 TextColor(11);
                 WriteLn(' (Generic ID)')
               end else WriteLn;
               TextColor(7);
             end;


{ subsystem vendor }
             Write(' Subsystem Vendor ',wrhexw(infotbl[$2d] shl 8+infotbl[$2c]),'h');

             if bogusid then
             begin
               TextColor(15);
               WriteLn(' Known Bad Subsystem ID - no Vendor ID readable');
               TextColor(7);
             end else
             begin
               if oemidnum<>'' then cmpstr:=oemidnum
               else cmpstr:=wrhexw(infotbl[$2d] shl 8+infotbl[$2c]);
               Close2(f);                { get back to start of file, as the}
               Reset2(f);                { subsys vendor may be higher up...!}
               failed:=true;
               if not Eof2(f) then
               begin
                 repeat
                   ReadLn2(f,vstr);
                   if (vstr[1]='V') and (Copy(vstr,3,4)=cmpstr) then
                   begin
                     TextColor(14);
                     WriteLn(' ',Copy(vstr,8,Length(vstr)));
                     failed:=false;
                     TextColor(7);
                   end;
                 until Eof2(f) or not failed;
               end;
               if failed then
               begin
                 TextColor(12);
                 WriteLn(' Unknown');
                 TextColor(7);
               end;
             end;
           end;


{ always }
           Close2(f);



           if not summary then
           begin

{ type 0 header = 5 entries, type 1 = 2, type 2 = skip }
           pp:=0;
           if infotbl[$e] and $7f=0 then pp:=5;
           if infotbl[$e] and $7f=1 then pp:=1;


           if pp>0 then for nn:=0 to pp do
           begin
             if infotbl[$10+(nn*4)]+infotbl[$11+(nn*4)]+
               infotbl[$12+(nn*4)]+infotbl[$13+(nn*4)]<>0 then
             begin
               Write(' Address ',nn,' is a');
               if infotbl[$10+(nn*4)] and 1=1 then
               begin
                 Write('n I/O Port : ');
                 addr:=infotbl[$13+(nn*4)] shl 8 + infotbl[$12+(nn*4)];
                 Write(wrhexw(addr));
                 addr:=infotbl[$11+(nn*4)] shl 8 + (infotbl[$10+(nn*4)] and $fc);
                 Write(wrhexw(addr),'h');
               end else
               begin
                 Write(' Memory Address');
                 if infotbl[$10+(nn*4)] and 6=0 then Write(' (anywhere in 0-4Gb');
                 if infotbl[$10+(nn*4)] and 6=2 then Write(' (below 1Mb');
                 if infotbl[$10+(nn*4)] and 6=4 then Write(' (anywhere in 64-bit space');
                 if infotbl[$10+(nn*4)] and 6=6 then Write(' (reserved');
                 if infotbl[$10+(nn*4)] and 8=8 then Write(', Prefetchable) : ') else Write(') : ');
                 addr:=infotbl[$13+(nn*4)] shl 8 + infotbl[$12+(nn*4)];
                 Write(wrhexw(addr));
                 addr:=infotbl[$11+(nn*4)] shl 8 + (infotbl[$10+(nn*4)] and $f0);
                 Write(wrhexw(addr)+'h');
               end;
               WriteLn;
             end;
           end;


           end;


{ all header types - list IRQ, if present }
           if (infotbl[$3c]<16) and (infotbl[$3c]>0) then
           begin
             Write(' System IRQ ',infotbl[$3c],', INT# ');
             if infotbl[$3d]=0 then Write('-') else Write(Chr(infotbl[$3d]+64));
             WriteLn;
             Inc(irqmap[infotbl[$3c]]);
           end;




           if not summary then
           begin



{ type 0,1 header - List ExpROM, if present }
           if (infotbl[$e] and $7f=0) or (infotbl[$e] and $7f=1) then
           begin
             if infotbl[$e] and $7f=0 then lb:=$30;
             if infotbl[$e] and $7f=1 then lb:=$38;
             if (infotbl[lb+3]<>0) or (infotbl[lb+2]<>0) or (infotbl[lb+1] and $f8<>0) then
             begin
               Write(' Expansion ROM at ',wrhexw(infotbl[lb+3] shl 8+infotbl[lb+2]));
               Write(wrhex(infotbl[lb+1] and $f8),'00h is ');
               if infotbl[lb] and 1=1 then WriteLn('enabled') else WriteLn('disabled');
             end;
           end;

           end;



{ type 1 header only - List bus numbers etc }

           if not summary then
           begin



           if infotbl[$e] and $7f=1 then
           begin
             Write(' Primary bus number ',infotbl[$18],', Secondary bus number ',infotbl[$19]);
             WriteLn(', Subordinate bus number ',infotbl[$1a]);

             Write(' Secondary bus latency ',wrhex(infotbl[$1b]),'h');
             WriteLn(', Secondary bus status ',wrhex(infotbl[$1f]),wrhex(infotbl[$1e]),'h');

             first:=true;
             Write(' Secondary bus controls : ');
             if infotbl[$3e] and 1=1 then printstatus('parity detection');
             if infotbl[$3e] and 4=4 then printstatus('ISA mapping');
             if infotbl[$3e] and 8=8 then printstatus('VGA mapping');
             if infotbl[$3e] and 32=32 then printstatus('master abort mode');
             if infotbl[$3e] and 128=128 then printstatus('back-to-back transactions');
             WriteLn;


{ I/O ports range accessable beyond bridge }
             if (infotbl[$1c]<>0) or (infotbl[$1d]<>0) then
             begin
               Write(' I/O Port range accessable beyond bridge : ');
               if infotbl[$1c] and $f=0 then Write(wrhexb(infotbl[$1c] shr 4),'000h to ') else
                 Write(wrhex(infotbl[$31]),wrhex(infotbl[$30]),wrhexb(infotbl[$1c] shr 4),'000h to ');
               if infotbl[$1d] and $f=0 then WriteLn(wrhexb(infotbl[$1d] shr 4),'FFFh') else
                 WriteLn(wrhex(infotbl[$33]),wrhex(infotbl[$32]),wrhexb(infotbl[$1d] shr 4),'FFFh');
             end;



           end;
           end;



{ type 2 header only - List bus numbers etc }

           if not summary then
           begin
             if infotbl[$e] and $7f=2 then
             begin
               Write(' PCI bus number ',infotbl[$18],', CardBus bus number ',infotbl[$19]);
               WriteLn(', Subordinate bus number ',infotbl[$1a]);
               WriteLn(' CardBus latency ',wrhex(infotbl[$1b]),'h');
             end;
           end;





           if not summary then
           begin





{ explore the capabilities list, if present
  (should ony be in type 0 or 2 headers???
  - not according to DEC 21150 pci bridge!)
}

           if infotbl[6] and $10=$10 then
           begin
             WriteLn(' Capabilities List Information :');
{type 0}     if infotbl[$e] and $7f=0 then cap_ptr:=infotbl[$34];
{type 1}     if infotbl[$e] and $7f=1 then cap_ptr:=infotbl[$34];
{type 2}     if infotbl[$e] and $7f=2 then cap_ptr:=infotbl[$14];
             repeat
               case infotbl[cap_ptr] of

                 01 : begin
                        WriteLn('  Power Management Capabilities');
{                        WriteLn('  PM Capabilities : ',wrhexw(infotbl[cap_ptr+3] shl 8 + infotbl[cap_ptr+2]),'h');}
{                        WriteLn('  PM Status : ',wrhexw(infotbl[cap_ptr+5] shl 8 + infotbl[cap_ptr+4]),'h');}
{                        WriteLn('  PM Bridge Extensions : ',wrhex(infotbl[cap_ptr+6]),'h');}
{                        WriteLn('  PM Data Register : ',wrhex(infotbl[cap_ptr+7]),'h');}
                        if infotbl[cap_ptr+3] and 4=4 then WriteLn('    Supports Power state D2');
                        if infotbl[cap_ptr+3] and 2=2 then WriteLn('    Supports Power state D1');
                        if infotbl[cap_ptr+3] and 1=0 then WriteLn('    Supports reduced clock speed (when idle)');
                        Write('    Current power state : D');
                        case infotbl[cap_ptr+4] and 3 of
                          0 : WriteLn('0');
                          1 : WriteLn('1');
                          2 : WriteLn('2');
                          3 : WriteLn('3');
                        end;
                      end;


                 02 : begin
                        Write('  AGP Capabilities, Version ');
                        WriteLn(infotbl[cap_ptr+2] shr 4,'.',infotbl[cap_ptr+2] and $0f);

                        { Status register }

                        Write('    AGP Speed(s) Supported : ');
                        if infotbl[cap_ptr+4] and 1=1 then Write('1x ');
                        if infotbl[cap_ptr+4] and 2=2 then Write('2x ');
                        if infotbl[cap_ptr+4] and 4=4 then Write('4x ');
                        if infotbl[cap_ptr+4] and 7=0 then
                        begin
                          TextColor(12);
                          Write('None!!');
                          TextColor(11);
                          Write(' (Assume Only 1x Support)');
                          TextColor(7);
                        end;
                        WriteLn;

                        Write('    FW Transfers Supported : ');
                        if infotbl[cap_ptr+4] and $10=$10 then WriteLn('Yes') else WriteLn('No');

                        Write('    >4Gb Address Space Supported : ');
                        if infotbl[cap_ptr+4] and $20=$20 then WriteLn('Yes') else WriteLn('No');

                        Write('    Sideband Addressing Supported : ');
                        if infotbl[cap_ptr+5] and 2=2 then WriteLn('Yes') else WriteLn('No');

                        Write('    Maximum Command Queue Length : ',infotbl[cap_ptr+7]+1,' byte');
                        if infotbl[cap_ptr+7]=0 then WriteLn else WriteLn('s');


                        { Command register }

                        Write('    AGP Speed Selected : ');
                        if infotbl[cap_ptr+8] and 1=1 then Write('1x ');
                        if infotbl[cap_ptr+8] and 2=2 then Write('2x ');
                        if infotbl[cap_ptr+8] and 4=4 then Write('4x ');
                        if infotbl[cap_ptr+8] and 7=0 then Write('None Selected');
                        WriteLn;

                        Write('    FW Transfers Enabled : ');
                        if infotbl[cap_ptr+8] and $10=$10 then WriteLn('Yes') else WriteLn('No');

                        Write('    >4Gb Address Space Enabled : ');
                        if infotbl[cap_ptr+8] and $20=$20 then WriteLn('Yes') else WriteLn('No');

                        Write('    AGP Enabled : ');
                        if infotbl[cap_ptr+9] and 1=1 then WriteLn('Yes') else WriteLn('No');

                        Write('    Sideband Addressing Enabled : ');
                        if infotbl[cap_ptr+9] and 2=2 then WriteLn('Yes') else WriteLn('No');

                        Write('    Current Command Queue Length : ',infotbl[cap_ptr+11]+1,' byte');
                        if infotbl[cap_ptr+11]=0 then WriteLn else WriteLn('s');
                      end;



                 05 : begin
                        WriteLn('  Message Signalled Interrupt Capability');
                        Write('    MSI is ');
                        if infotbl[cap_ptr+2] and 1=1 then WriteLn('enabled') else WriteLn('disabled');
                      end;



                 else WriteLn('  Unknown Capability (Code ',wrhex(infotbl[cap_ptr]),'h)!!');
               end;
               cap_ptr:=infotbl[cap_ptr+1];
             until cap_ptr=0;
           end;


           end;


{ do a hex-dump, if requested }
           if dumpregs then
           begin
             WriteLn;
             WriteLn(' Hex-Dump of device configuration space follows:');
             Write('  0000  ');
             for i:=0 to $ff do
             begin
               if (i>0) and (i mod 16=0) then
               begin
                 Write('   ');
                 for j:=i-16 to i-1 do if Ord(infotbl[j])<32 then Write('.') else Write(Chr(infotbl[j]));
                 WriteLn;
                 Write('  ',wrhexw(i),'  ');
               end;
               Write(wrhex(infotbl[i]),' ');
             end;
             Write('   ');
             for j:=240 to 255 do if Ord(infotbl[j])<32 then Write('.') else Write(Chr(infotbl[j]));
             WriteLn;
           end;








           WriteLn;             { space between devices }



{ If not multi-device device, then don't test for func 1-7 as some cards
incorrectly answer back on all 8 function numbers!!! S3 trio64, for example - stupid!  }

           if (func=0) and (infotbl[$e] and $80=0) then func:=7;
         end;
       end;
      end;
    end;
































{
  The following is an experiment with "Get IRQ Routing Info" BIOS function:
  the avid coder is free to un-comment the code and try it out: I couldn't
  make much sense out of the information returned myself!
}



     if dopcirouting then
    begin


      WriteLn;
      WriteLn('PCI slot IRQ mapping information');

      failed:=true;
      FillChar(irqbuff,SizeOf(irqbuff),$00);
      load_irqbuff;

      if not failed then
      begin
        TextColor(10);
        WriteLn(' PCI slot mapping information read successfully');
        TextColor(7);
        WriteLn;

{ hex-dump table }
        if dumpregs then
        begin
          WriteLn('Hex-Dump of IRQ Routing table : ');
          WriteLn;
          {
          Write('  0000  ');
          for i:=0 to 1023 do
          begin
            if (i>0) and (i mod 16=0) then
            begin
              Write('   ');
              for j:=i-16 to i-1 do if Ord(irqbuff[j])<32 then Write('.') else Write(Chr(irqbuff[j]));
              WriteLn;
              Write('  ',wrhexw(i),'  ');
            end;
            Write(wrhex(irqbuff[i]),' ');
          end;
          Write('   ');
          for j:=1024-16 to 1024-1 do if Ord( irqbuff[j])<32 then Write('.') else Write(Chr(irqbuff[j]));
          WriteLn;
          WriteLn;
          }
          for i:=0 to (len-1) shr 4 do
            begin
              Write('  ',wrhexw(i shl 4),'  ');

              for j:=0 to 15 do
                Write(wrhex(irqbuff[6+i shl 4+j]),' ');

              Write('   ');

              for j:=0 to 15 do
                if Ord( irqbuff[6+i shl 4+j])<32 then
                  Write('.')
                else
                  Write(Chr(irqbuff[6+i shl 4+j]));

              WriteLn('   ');
            end;
        end;


{}
        WriteLn(' PCI slot IRQ availability listing');
        WriteLn;
        for i:=0 to (len shr 4)-1 do
        begin
          WriteLn('  PCI Bus ',irqbuff[6+(i*16)],', Device ',irqbuff[6+1+(i*16)] shr 3,', Slot ',wrhex(irqbuff[6+14+(i*16)]));
          listmap(irqbuff[6+ 4+(i*16)] shl 8 + irqbuff[6+ 3+(i*16)],'   INTA# can be connected to IRQs ');
          listmap(irqbuff[6+ 7+(i*16)] shl 8 + irqbuff[6+ 6+(i*16)],'   INTB# can be connected to IRQs ');
          listmap(irqbuff[6+10+(i*16)] shl 8 + irqbuff[6+ 9+(i*16)],'   INTC# can be connected to IRQs ');
          listmap(irqbuff[6+13+(i*16)] shl 8 + irqbuff[6+12+(i*16)],'   INTD# can be connected to IRQs ');
          WriteLn;
        end;
        WriteLn;


{}
        WriteLn(' PCI slot INTx to IRQ-router mappings');
        WriteLn;
        WriteLn('  SLOT BUS DEV  INTA INTB INTC INTD');
        for i:=0 to (len shr 4)-1 do
        begin
          Write('   ',wrhex(irqbuff[6+14+(i*16)]),'  ',irqbuff[6+0+(i*16)]:2,'  ',irqbuff[6+1+(i*16)] shr 3:2);
          Write('    ',wrhex(irqbuff[6+2+(i*16)]),'   ',wrhex(irqbuff[6+5+(i*16)]),'   ',
            wrhex(irqbuff[6+8+(i*16)]),'   ',wrhex(irqbuff[6+11+(i*16)]),'  ');

          if usebios then
          begin
            infotbl[0]:=lookup_bios(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],0);
            infotbl[1]:=lookup_bios(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],1);
            infotbl[2]:=lookup_bios(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],2);
            infotbl[3]:=lookup_bios(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],3);
            infotbl[4]:=lookup_bios(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],4);
            infotbl[5]:=lookup_bios(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],5);
            infotbl[6]:=lookup_bios(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],6);
            infotbl[7]:=lookup_bios(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],7);
          end else
          begin
            infotbl[0]:=lookup_hw(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],0);
            infotbl[1]:=lookup_hw(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],1);
            infotbl[2]:=lookup_hw(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],2);
            infotbl[3]:=lookup_hw(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],3);
            infotbl[4]:=lookup_hw(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],4);
            infotbl[5]:=lookup_hw(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],5);
            infotbl[6]:=lookup_hw(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],6);
            infotbl[7]:=lookup_hw(irqbuff[6+1+(i*16)] shr 3,0,irqbuff[6+0+(i*16)],7);
          end;

          cmpstr:=wrhexw(infotbl[1] shl 8+infotbl[0]);
          if cmpstr<>'FFFF' then
          begin
            lookupven(true);
            cmpstr:=wrhexw(infotbl[3] shl 8+infotbl[2]);
            lookupdev;
          end else Write('No Device Detected');




          WriteLn;
        end;
        WriteLn;


{}
        listmap(conmap,' IRQ''s dedicated to PCI : ');

      end else
      begin
        TextColor(12);
        WriteLn(' Unable to read slot mapping information from PCI BIOS!');
        TextColor(7);
      end;
      WriteLn;
    end;
























{ BIOS IRQ Routing table tests }

    if dorouting then
    begin
      WriteLn('ROM PCI IRQ routing table Windows 9x Compatibility Tests....');


{ Find table }
      i:=0;
      failed:=true;
      repeat
        if MemL_F000(i)=$52495024 then (* $PIR *)
          failed:=false
        else
          Inc(i,16);
      until (i>$ffef) or not failed;


{ check table }
      if not failed then
      begin

        tableok:=true;

        WriteLn(' ROM IRQ routing table found at F000h:',wrhexw(i),'h');
        Write(' Table Version ',Mem_F000(i+5),'.',Mem_F000(i+4));
        if (Mem_F000(i+5)=1) and (Mem_F000(i+4)=0) then WriteLn(' - OK') else
        begin
          TextColor(12);
          WriteLn('Invalid Version!');
          TextColor(7);
          tableok:=false;
        end;

        Write(' Table size ',MemW_F000(i+6),' bytes - ');
        if (MemW_F000(i+6)<33) or (MemW_F000(i+6) mod 16<>0) then
        begin
          TextColor(12);
          WriteLn('Invalid Size!');
          TextColor(7);
          tableok:=false;
        end else WriteLn('OK');



        Write(' Table Checksum ',wrhex(Mem_F000(i+31)),'h - ');
        {$R-}  {Range checking off as sum is DELIBERATELY meant to overfow }
        sum:=0;
        for l:=0 to MemW_F000(i+6)-1 do
        begin
          sum:=sum+Mem_F000(i+l);
        end;
        {$R+}
        if sum=0 then WriteLn('OK') else
        begin
          TextColor(12);
          WriteLn('Failed!');
          TextColor(7);
          tableok:=false;
        end;


        listmap(MemW_F000(i+10),' IRQ''s dedicated to PCI : ');


        if tableok then
        begin
          TextColor(10);
          WriteLn(' The ROM PCI IRQ routing table appears to be OK.');
          TextColor(7);
        end else
        begin
          TextColor(12);
          WriteLn(' The ROM PCI IRQ routing table appears to be faulty!!');
          TextColor(7);
        end;

      end else
      begin
        TextColor(12);
        WriteLn('No ROM PCI IRQ routing table found!!!');
        TextColor(7);
      end;
    end;





{ final summarial IRQ info }

    WriteLn;

    Write('IRQ Summary: ');
    failed:=true;
    disp:=0;
    for i:=0 to 15 do if irqmap[i]>0 then Inc(disp); { count IRQs}
    for i:=0 to 15 do if irqmap[i]>0 then
    begin
      if failed then
      begin
        if disp=1 then Write('IRQ ') else Write('IRQs ');
      end else Write(',');
      Write(i);
      failed:=false;
    end;
    if failed then WriteLn('No IRQ''s are used by PCI Devices!') else
    begin
      if disp=1 then Write(' is') else Write(' are');
      WriteLn(' used by PCI devices');
    end;

    Write('Shared IRQs: ');
    failed:=true;
    for i:=0 to 15 do if irqmap[i]>1 then
    begin
      if not failed then Write('             ');
      WriteLn('IRQ ',i,' is shared by ',irqmap[i],' PCI Devices');
      failed:=false;
    end;
    if failed then WriteLn('There are no shared PCI IRQs');



  end;
  (*$IFDEF OS2*)
  close_oemhlp;
  (*$ENDIF*)
end.