读写USB问题(100分)

哪位大侠有读写USB的例子或资料？
有用一定送分！！！

到www.usb.org上去下载个USBVIEW，

我有，怎么给你。QQ：27032000

如有相关资料，可email给我：liu9536@sina.com

to fpsky:
关注，能给我一份吗？
email:lzj@sina.com
谢谢

能给我一份吗？
guan_qingxi@yahoo.com.cn

给我一份，谢谢
horneye_zhou@yahoo.com.cn

也给我一份吧，多谢！eddycao@sina.com

也给我一份吧，多谢！gxlzbig@263.net

有好例子吗？
wcdxyl@163.com
好的话我发贴发分

usbview在98的reskit里就有

有SDK吧。

方便给我发一份吗谢谢！ jiaobo@joyan.com.cn

这里有
http://www.driverdevelop.com/

{$A+,B-,D+,E+,F-,G+,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+,Y+}

{ ************************************************************************ }
{ USB.PAS: SB BASIC Routines by Dieter R. Pawelczak <dieterp@bigfoot.de> }
{ ======================================================================== }
{ }
{ Unit to initialize and address the USB Host Controller }
{ }
{ (c) 1998 by Dieter Pawelczak, <dieterp@bigfoot.de> }
{ This is publicdo
main Software - selling this software is prohibeted! }
{ }
{ function DetectVirtualRealMode(..) detects virtual real mode
{ function USBdetect(..);
detects an PCI USB Controller -do
ne by INIT
{ function USBEnable enables USB Controller PCI-BUS Master
{ function USBGetDeviceIOSpace(..) reads I/O port address
{ function USBSetDeviceIOSpace(..) sets I/O port address
{ function USBReadCommandReg read access IOCommandRegister
{ procedure USBWriteCommandReg write access IOCommandRegister
{
{ Initialization should first check the USB device (test USBdetected),
{ read the I/O address space and if zero set an unused port address space
{ (32 byte), now PIC-BUS Master Control can be enabled by USBenable
{ }
{ ************************************************************************ }

{$define DEBUG} { Enables DEBUG Output }

unit usb;

interface

{$IFDEF DEBUG}
uses PCI,dutils;
{$else
}
uses PCI;
{$ENDIF}





const { USB-Command Regiser }

MAXP=$80;
CF=$40;
SWDBG=$20;
FGR=$10;
EGSM=$08;
GRESET=$04;
HCRESET=$02;
RS=$01;



type FrameListPointer = longint;
{ 32 bit address + Q &amp;
T flag }
type FrameListPointerArray = Array[0..1023] of FrameListPointer;
type FrameList = ^FrameListPointerArray;


type LinkPointer = longint;
{ 32 bit address + Vf &amp;
Q &amp;
T flag }
type BufferPointer = longint;
{ 32 bit address of the data buffer }

type TransferDescriptor = record
next:LinkPointer;
{ points to next T/Q descriptor or indicates termination by T-flag }
ActLen: word;
{ presents the actual length (11 bit ) = and 2047 }
Status: byte;
{ presents the Status }
Flags:Byte;
{ Flags SPD(5), C_ERR(4,3), LS(2), ISO(1), IOC (0)}
Token: longint;
{ MaxLen/R/R/EndPt/DeviceAddr/PID to be sent }
BufferPtr: BufferPointer;
{ Buffer Pointer for Data }
res:array[0..3] of longint;
end;

type transmitstatusptr=^byte;
type QueueHeadLinkPointer = longint;
{ 32 bit address + Q &amp;
T flag }
type QueueHeadElementPointer = longint;
{ 32 bit address + Q &amp;
T flag, bit 2 is undefined (write as 0) }

type QueueHead = record
next:QueueHeadLinkPointer;
{ points to next T/Q descriptor or indicates termination by T-flag }
Element:QueueHeadElementPointer;
{ points to next Queue Operation or indicates termination by T-flag }
end;


type PortState = (port_disabled, port_newAttached, port_enabled, port_configured);

type USBRequest = record
bmRequestType:Byte;
bRequest:byte;
wValue:word;
wIndex:word;
wLength:word;
end;


const GetDeviceDescriptor : USBRequest =
(bmRequestType:$80;bRequest:$06;wValue:$0001;wIndex:$0000;wLength:$0012);
const SetAddress : USBRequest =
(bmRequestType:$00;bRequest:$05;wValue:$0001;wIndex:$0000;wLength:$0000);


var USBDeviceID,USBVendorID:word;
{ PCI-Identification USB Controller }
USBBusNumber,USBFunctionNumber:Byte;
USBDescription:string;
{ Text Description }
USBIOSpace:word;
{ I/O address space set/read }
USBdetected:boolean;
{ Flag set by INIT }


var ISADeviceID,ISAVendorID:word;
{ PCI-Identification PCI-ISA Controller }
ISABusNumber,ISAFunctionNumber:Byte;
{ needed by USBSetInt }
ISADescription:string;
{ Text Description }
ISAdetected:boolean;
{ Flag set by INIT }

var FrameListPtr:FrameList;
{ pointer to the frame list }
FrameListBase:longint;
{ frame list 32 bit base address}
FrameListHandleointer;
{ TP memory handle }


{ LOW LEVEL: USB-Host Controller and PCI functions }
function USBdetect(Var DeviceID,VendorID:word;VAR BusNumber,FunctionNumber:Byte;var Description:string):boolean;
function USBEnable:boolean;
function USBDisable:boolean;
function USBGetDeviceIOSpace(var IOSpace:word):boolean;
function USBSetDeviceIOSpace(IOSpace:word):boolean;
function USBReadCommandReg:word;
function USBReadStatusReg:word;
function USBReadPort0Reg:word;
function USBReadPort1Reg:word;
function USBReadInterruptReg:word;
function USBReadFrameBaseReg:longint;
function USBReadFrameNumberReg:word;
procedure USBWriteCommandReg(value:word);
procedure USBWriteStatusReg(value:word);
procedure USBWriteInterruptReg(value:word);
procedure USBWriteFrameNumberReg(value:word);
procedure USBWritePort0Reg(value:word);
procedure USBWritePort1Reg(value:word);
function USBSetInterruptNumber(IntNo:word;
active:boolean):boolean;
function USBGetInterruptNumber(Var IntNo:word;Var active:boolean):boolean;
function USBAllocateFrameList(Var FList:FrameList;VAR FLBase:FrameListPointer):boolean;
procedure USBCommandRun;
procedure USBCommandStop;
procedure USBDone;
procedure usbclearframelist;

{ General USB Functions }

function AllocateTransferDescriptorointer;
{ Returns pointer to TD or nil }
procedure FreeTransferDescriptor(pointer);
function CreateTransferDescriptor(Terminate,Queue,Depth:boolean;Link:linkpointer;
Actln:word;State:word;IOC,IOS,LS:Boolean;C_error:byte;SPD:boolean;
PID,DeviceAddress,EndPt:Byte;DataToggle:boolean;MaxLen:word;
BPtr:BufferPointer)ointer;
{ Allocates and configures TD - Returns pointer to TD or nil }
procedure AlterTransferDescriptor(pointer;Actln:word;State:word;IOC,IOS,LS:Boolean;C_error:byte;SPD:boolean);

procedure InsertQueueDescriptorInFrameList(Number:word;pointer);
procedure InsertTransferDescriptorInFrameList(Number:word;pointer);
function GetLinkPointerFromTransferDescriptor(pointer):LinkPointer;
function GetLinkPointerFromFrameList(number:word):LinkPointer;
function GetTransferDescriptorFromFrameList(number:word)ointer;
function GetTransferDescriptorFromLinkPointer(l:linkpointer)ointer;
{ Helpers }

function DetectVirtualRealMode:boolean;
function GetPtrBase(pointer):longint;
function GetBasePtr(b:longint)ointer;


{$IFDEF DEBUG}
procedure USBprintTD(Pointer);
procedure USBprintFrameList;
{$ENDIF}

implementation

function USBdetect(Var DeviceID,VendorID:word;VAR BusNumber,FunctionNumber:Byte;var Description:string):boolean;
var i:byte;
error,found:boolean;
begin

BusNumber:=0;FunctionNumber:=0;
USBdetect:=false;
i:=0;
error:=false;
found:=false;
repeat { check different possible USB-PCI devices ... }
case i of
0: begin
deviceId:=$7020;vendorId:=$8086;
description:='Intel 82371SB USB controller';
end;

1: begin
deviceId:=$7112;vendorId:=$8086;
description:='Intel PIIX4 USB controller';
end;

2: begin
deviceId:=$0571;vendorId:=$1106;
description:='VIA AMD-645 USB controller';
end;

3: begin
deviceId:=$A0F8;vendorID:=$1045;
description:='Opti 82C750 (Vendetta) USB controller';
end;

4: begin
deviceId:=$C861;vendorID:=$1045;
description:='Opti 82C861/871 (Firelink/FireBlast) USB controller';
end;

end;

inc(i);
found:=detectPCIdevice(deviceId,vendorId,BusNumber,FunctionNumber);
error:=i>4;
until error or found;
USBdetect:=found;
end;


function ISAdetect(Var DeviceID,VendorID:word;VAR BusNumber,FunctionNumber:Byte;var Description:string):boolean;
var i:byte;
error,found:boolean;
begin

BusNumber:=0;FunctionNumber:=0;
ISAdetect:=false;
i:=0;
error:=false;
found:=false;
repeat { check different possible ISA-PCI devices ... }
case i of
0: begin
deviceId:=$7000;vendorId:=$8086;
description:='Intel 82371SB ISA-PCI controller';
end;

1: begin
deviceId:=$7110;vendorId:=$8086;
description:='Intel PIIX4 ISA-PCI controller';
end;

{ 2: begin
deviceId:=$0571;vendorId:=$1106;
description:='VIA AMD-645 USB controller';
end;

3: begin
deviceId:=$A0F8;vendorID:=$1045;
description:='Opti 82C750 (Vendetta) USB controller';
end;

4: begin
deviceId:=$C861;vendorID:=$1045;
description:='Opti 82C861/871 (Firelink/FireBlast) USB controller';
end;

}
end;

inc(i);
found:=detectPCIdevice(deviceId,vendorId,BusNumber,FunctionNumber);
error:=i>2;
until error or found;
ISAdetect:=found;
end;


function USBGetDeviceIOSpace(var IOSpace:word):boolean;
var okay:boolean;
result:word;
setiospace:word;
begin

okay:=false;
if readPCIRegisterWord($20,USBBusNumber,USBFunctionNumber,result) then

begin

okay:=true;
IOSpace:=result and $FFFE;
USBIOSpace:=IOSpace;
end;

USBGetDeviceIOSpace:=okay;
end;


function USBSetDeviceIOSpace(IOSpace:word):boolean;
var okay:boolean;
result:word;
setiospace:word;
begin

okay:=false;
IOSpace:=IOSpace ;
if writePCIRegisterWord($20,USBBusNumber,USBFunctionNumber,IOSpace) then

begin

okay:=true;
USBIOSpace:=IOSpace;
end;

USBSetDeviceIOSpace:=okay;
end;


function USBReadCommandReg:word;
begin

USBReadCommandReg:=portw[USBIOSpace];
end;


function USBReadStatusReg:word;
begin

USBReadStatusReg:=portw[USBIOSpace+2];
end;


function USBReadInterruptReg:word;
begin

USBReadInterruptReg:=portw[USBIOSpace+4];
end;


function USBReadPort0Reg:word;
begin

USBReadPort0Reg:=portw[USBIOSpace+16];
end;


procedure USBWritePort0Reg(value:word);
begin

portw[USBIOSpace+16]:=value;
end;


function USBReadPort1Reg:word;
begin

USBReadPort1Reg:=portw[USBIOSpace+18];
end;


procedure USBWritePort1Reg(value:word);
begin

portw[USBIOSpace+18]:=value;
end;


procedure USBWriteInterruptReg(value:word);
begin

portw[USBIOSpace+4]:=value;
end;


procedure USBWriteStatusReg(value:word);
begin

portw[USBIOSpace+2]:=value;
end;


procedure USBWriteCommandReg(value:word);
begin

portw[USBIOSpace]:=value;
end;


procedure USBWriteFrameNumberReg(value:word);
begin

portw[USBIOSpace+6]:=value;
end;


function USBReadFrameNumberReg:word;
begin

USBReadFrameNumberReg:=portw[USBIOSpace+6];
end;


function USBReadFrameBaseReg:longint;
begin

asm
mov dx,USBIOSpace
add dx,08h
db 66h;
in ax,dx { in dx,eax }
db 66h;
mov word ptr FrameListBase,ax { mov ..,eax }
end;

USBReadFrameBaseReg:=FrameListBase;
end;


function USBEnable:boolean;
var okay:boolean;
command:word;
begin

okay:=false;
if usbdetected and (USBIOspace<>0) then

if readPCIRegisterWord($4,USBBusNumber,USBFunctionNumber,command) then

begin

okay:=command and 5=5;
command:=command or 5;
if writePCIRegisterWord($4,USBBusNumber,USBFunctionNumber,command) then

okay:=true;
end;

USBenable:=okay;
end;


function USBGetInterruptNumber(Var IntNo:word;Var active:boolean):boolean;
var okay:boolean;
command:longint;
command2:longint;
begin

okay:=false;
active:=false;
if isadetected then

if readPCIRegisterDWord($60,ISABusNumber,ISAFunctionNumber,command) then

begin

intno:=command shr 24;
active:=intno and 128=0;
intno:=intno and 15;
okay:=true;
end;

USBGetInterruptNumber:=okay;
end;


function USBSetInterruptNumber(IntNo:word;active:boolean):boolean;
var okay:boolean;
command:byte;
command2:word;
dummy:word;
begin

okay:=false;
asm
cli
end;

if isadetected then

if readPCIRegisterByte($63,ISABusNumber,ISAFunctionNumber,command) then

begin

{ Redirect IRQD = Register 63h to ISA-BUS IRQ }
command:=IntNo+ord(not active)*128;
{ Set interrupt Number to MSB }
command2:=1 shl intno;
if command2>255 then

begin

dummy:=port[$4d1] and (not (command2 shr 8));
port[$4d1]:=port[$4d1] and (not (command2 shr 8));
end else

begin

dummy:=port[$4d0] and (not (command2 shr 8));
port[$4d0]:=port[$4d0] and (not (command2));
end;

dummy:=port[$21];
if writePCIRegisterByte($63,ISABusNumber,ISAFunctionNumber,command) then

begin

dummy:=port[$21];
{ Set Interrupt Sensitive Mode }
okay:=true;
end;

if intno>7 then

begin

asm
in al,0a1h
mov cl,byte ptr intno
sub cl,8
mov dl,1
shl dl,cl
not dl
and al,dl
out 0a1h,al
in al,021h
mov dl,2
not dl
and al,dl
out 021h,al
end;

end else

begin

asm
in al,021h
mov cl,byte ptr intno
mov dl,1
shl dl,cl
not dl
and al,dl
out 021h,al
end;

end;


end;

asm
sti
end;

USBSetInterruptNumber:=okay;
end;


function USBDisable:boolean;
var okay:boolean;
begin

okay:=false;
if usbdetected and (USBIOspace<>0) then

if WritePCIRegisterWord($4,USBBusNumber,USBFunctionNumber,0) then

begin

okay:=true;
end;

USBDisable:=okay;
end;


procedure usbclearframelist;
var i:word;
begin

for i:=0 to 1023do

FrameListPtr^:= 1;
{ Set Terminate }
end;


function USBAllocateFrameList(Var FList:FrameList;VAR FLBase:FrameListPointer):boolean;
var okay:boolean;
i:word;
begin

if memavail>8192 then

begin

getmem(FrameListHandle,8192);
FrameListBase:=longint(seg(FrameListHandle^)) shl 4+longint(ofs(FrameListHandle^));
{ 4K alignment }
FrameListBase:=longint(FrameListbase + 4096) and $fffff000;
FrameListPtr:=getbaseptr(FrameListBase);
FList:=FrameListPtr;
FLBase:=FrameListBase;
USBWriteFrameNumberReg(0);
for i:=0 to 1023do

FrameListPtr^:= 1;
{ Set Terminate }
asm
mov dx,USBIOSpace
add dx,08h
db 66h;
mov ax, word ptr FrameListBase { mov eax, ... }
db 66h;
out dx,ax { out dx,eax }
end;

USBWriteFrameNumberReg(0);
okay:=true;
end;

USBAllocateFrameList:=okay;
end;


procedure InsertTransferDescriptorInFrameList(Number:word;pointer);
begin

FrameListPtr^[Number]:= getPtrBase(p) and $fffffffc;
end;


function GetLinkPointerFromFrameList(number:word):LinkPointer;
begin

GetLinkPointerFromFrameList:=FrameListPtr^[Number] and $fffffffc;
end;


procedure InsertQueueDescriptorInFrameList(Number:word;pointer);
begin

FrameListPtr^[Number]:= getPtrBase(p) and $fffffffc +2;
end;




procedure USBCommandRun;
var value:word;
begin

value:=USBReadCommandReg;
value:=value or 1;
USBWriteCommandReg(value);
end;


procedure USBCommandStop;
var value:word;
begin

value:=USBReadCommandReg;
value:=value and $fe;
USBWriteCommandReg(value);
end;



function DetectVirtualRealMode:boolean;assembler;
asm
smsw ax
and ax,1
end;


function GetPtrBase(pointer):longint;
begin

GetPtrBase:=longint(seg(p^)) shl 4 + longint(ofs(p^));
end;


function GetBasePtr(b:longint)ointer;
var h1,h2:longint;
begin

h1:=b shr 4;
h2:=b and $f;
GetbasePtr:=Ptr(h1,h2);
end;


function AllocateTransferDescriptorointer;
var i,j,k:word;
p1:^transferdescriptor;
PA:array[1..1000] of pointer;
begin

p1:=nil;
getmem(p1,32);
if ofs(p1^) and $f<>0 then

begin

j:=0;
repeat
inc(j);
freemem(p1,32);p1:=NIL;
getmem(pa[j],1);
getmem(p1,32);
until (j=1000) or (ofs(p1^)=0);
if j=1000 then

begin

writeln('Fatal: Allocating TD memory error...');
halt(3);
end;

for k:=1 to jdo
Freemem(pa[k],1);
end;

if p1<>NIL then

with p1^do

begin

next:=0;
ActLen:=0;
Status:=0;
Flags:=0;
token:=0;
BufferPtr:=0;
end;

AllocateTransferDescriptor:=p1;
end;


procedure FreeTransferDescriptor(pointer);
var td:^TransferDescriptor;
begin

freemem(p,32);
end;


function GetLinkPointerFromTransferDescriptor(pointer):LinkPointer;
begin

GetLinkPointerFromTransferDescriptor:=getptrbase(p);
end;


function GetTransferDescriptorFromLinkPointer(l:linkpointer)ointer;
begin

GetTransferDescriptorFromLinkPointer:=getbaseptr(l and $fffffffc) ;
end;


function GetTransferDescriptorFromFrameList(number:word)ointer;
begin

GetTransferDescriptorFromFrameList:=getbaseptr(FrameListPtr^[Number] and $fffffffc);
end;


procedure AlterTransferDescriptor(pointer;Actln:word;State:word;IOC,IOS,LS:Boolean;C_error:byte;SPD:boolean);
var td:^TransferDescriptor;
begin

td:=p;
if td<>nil then
with td^do

begin

Actlen:=Actln;
flags:=ord(IOC)+ord(IOS) shl 1 +ord(ls) shl 2+(c_error and 3) shl 3+ord(spd) shl 5;
Status:=state;
end;

end;


function CreateTransferDescriptor(Terminate,Queue,Depth:boolean;Link:linkpointer;
Actln:word;State:word;IOC,IOS,LS:Boolean;C_error:byte;SPD:boolean;
PID,DeviceAddress,EndPt:Byte;DataToggle:boolean;MaxLen:word;
BPtr:BufferPointer)ointer;
{ Allocates and configures TD - Returns pointer to TD or nil }
var td:^TransferDescriptor;
begin

td:=AllocateTransferDescriptor;
if td<>nil then
with td^do

begin

next:=link and $fffffff0+ord(Terminate)+ord(Queue) shl 1+ord(Depth) shl 2;
Actlen:=Actln;
Status:=state;
flags:=ord(IOC)+ord(IOS) shl 1 +ord(ls) shl 2+(c_error and 3) shl 3+ord(spd) shl 5;
token:=pid+longint(DeviceAddress) shl 8+longint(EndPt) shl 15+longint(ord(DataToggle)) shl 19+longint(maxlen) shl 21;
bufferPtr:=Bptr;

end;

CreateTransferDescriptor:=td;
end;


{$IFDEF DEBUG}
procedure USBprintLinkPtr(L:LinkPointer);
var h:longint;
i:word;
begin

h:=l and $fffffff0;
write('LinkPtr: ');
if h=0 then
write('-EMPTY- [');
write('- [',hexs(h));
if l and 4=4 then
write('] Vf ') else
write('] -- ');
if l and 2=2 then
write(' Q ') else
write(' - ');
if l and 1=1 then
write(' T ') else
write(' - ');
writeln;
end;


procedure USBprintFrameList;
var i,j:word;
l:longint;
begin

write('FrameList---------------[',hexs(FrameListBase),']---------------------------------------');
for i:=0 to 1023do

begin

if i mod 6=0 then
writeln;
l:=FrameListPtr^;
write('[',hexs(l),']');
if l and 2=2 then
write('Q') else
write('-');
if l and 1=1 then
write('T') else
write('-');
write(' ');
end;

writeln;
writeLn('-------------------------------------------------------------------------');
end;


procedure USBprintTD(Pointer);
var td:^TransferDescriptor;
i:word;
h:longint;
hp:^byte;
begin

td:=p;
with td^do

begin

writeLn('Transfer Descriptor-----[',hexs(GetPtrBase(p)),']---------------------------------------');
USBprintLinkPtr(next);
write('Control: ');
if flags and 32=32 then
write(' SP ') else
write(' -- ');
write('C_ERROR: ',chr(48+ord(flags and 16=16)),chr(48+ord(flags and 8=8)));
if flags and 4=4 then
write(' LS ') else
write(' -- ');
if flags and 2=2 then
write(' ISO ') else
write(' --- ');
if flags and 1=1 then
write(' ICO ') else
write(' --- ');
write(' Status: ',bins8(status));
writeln(' Len: ',Actlen);
write('Token: MaxLen: ',Token shr 21 and $7ff);
write(' Toggle: ',(Token shr 19) and 1);
WRite(' EndPt:',hexs8((Token shr 15) and $f));
WRite(' DevAddr:',hexs8((Token shr 8) and $7f));
WRite(' PID:',hexs8((Token) and $ff));
writeln;
write('BufferPtr:',hexs(bufferptr));
if bufferptr<>0 then

begin

write(' - ');
hp:=getBasePtr(bufferptr);
for i:=1 to 8do

begin

write(hexs8(hp^),' ');
inc(hp);
end;

end;

writeln;


writeLn('-------------------------------------------------------------------------');
end;

end;




{$ENDIF}


var oldmasterintmask:byte;
oldslaveintmask:byte;
old_port4d0:byte;
old_port4d1:byte;
old_pirqd:byte;

procedure USBDone;
begin

port[$4d0]:=old_port4d0;
port[$4d1]:=old_port4d1;
WritePCIRegisterByte($63,ISABusNumber,ISAFunctionNumber,old_pirqd);
asm
mov al,oldslaveintmask
out 0a1h,al
mov al,oldmasterintmask
out 021h,al
end;

end;


begin

USBdetected:=false;
if detectPCIbios then

begin

USBdetected:=USBdetect(USBDeviceId,USBVendorId,USBBusNumber,USBFunctionNumber,USBdescription);
ISAdetected:=ISAdetect(ISADeviceId,ISAVendorId,ISABusNumber,ISAFunctionNumber,ISAdescription);
old_port4d0:=port[$4d0];
old_port4d1:=port[$4d1];
readPCIRegisterByte($63,ISABusNumber,ISAFunctionNumber,old_pirqd);
asm
in al,0a1h
mov oldslaveIntMask,al
in al,021h
mov oldmasterIntMask,al
end;

end;

end.

uses PCI,dutils
会出错,why?

我也来一份

king_micheal_168@yahoo.com.cn

顶上去

{ ************************************************************************ }
{ PCI.PAS: PCI BIOS Routines by Dieter R. Pawelczak <dieterp@bigfoot.de> }
{ ======================================================================== }
{ }
{ Unit to detect PCI-Devices and to read/write to }
{ its configuration registers }
{ }
{ (c) 1998 by Dieter Pawelczak, <dieterp@bigfoot.de> }
{ This is publicdo
main Software - selling this software is prohibeted! }
{ }
{ ************************************************************************ }

{$G+}


unit PCI;
interface

function detectPCIBios:boolean;
function detectPCIdevice(DeviceID:Word;VendorID:Word;VAR BusNumber:Byte;VAR FunctionNumber:Byte):boolean;
function readPCIRegisterByte(RegisterNumber:word;BusNumber:Byte;FunctionNumber:Byte;var result:byte):boolean;
function readPCIRegisterWord(RegisterNumber:word;BusNumber:Byte;FunctionNumber:Byte;var result:Word):boolean;
function readPCIRegisterDWord(RegisterNumber:word;BusNumber:Byte;FunctionNumber:Byte;var result:longint):boolean;
function writePCIRegisterByte(RegisterNumber:word;BusNumber:Byte;FunctionNumber:Byte;input:byte):boolean;
function writePCIRegisterWord(RegisterNumber:word;BusNumber:Byte;FunctionNumber:Byte;input:word):boolean;
function writePCIRegisterDWord(RegisterNumber:word;BusNumber:Byte;FunctionNumber:Byte;input:longint):boolean;

implementation

function detectPCIBios:boolean;assembler;
asm
mov ax,0b101h
int 1ah
jc @nopcibios
mov ax,1
ret
@nopcibios:
xor ax,ax
ret
end;


function detectPCIdevice(DeviceID:Word;VendorID:Word;VAR BusNumber:Byte;VAR FunctionNumber:Byte):boolean;
var found:boolean;
bn:byte;
fn:byte;
begin

bn:=0;fn:=0;
found:=false;
asm
db 66h;pusha
mov cx,DeviceID
mov dx,VendorID
mov ax,0b102h
xor si,si
int 1ah
jc @nodevice
mov found,true
mov bn,BH
mov fn,BL
@nodevice:
db 66h;popa
end;

BusNumber:=bn;FunctionNumber:=fn;
detectPCIdevice:=found;
end;


function readPCIRegisterByte(RegisterNumber:word;BusNumber:Byte;FunctionNumber:Byte;var result:byte):boolean;
var okay:boolean;
res:byte;
begin

okay:=false;
res:=0;
asm
db 66h;
pusha
mov AX,0B108h
mov BH,busNumber
mov BL,functionNumber
mov DI,RegisterNumber
int 1Ah
jc @noaction
mov res,cl
mov okay,true
@noaction:
db 66h;
popa
end;

result:=res;
readPCIRegisterByte:=okay;
end;


function readPCIRegisterWord(RegisterNumber:word;BusNumber:Byte;FunctionNumber:Byte;var result:Word):boolean;
var okay:boolean;
res:word;
begin

okay:=false;
res:=0;
asm
db 66h;
pusha
mov AX,0B109h
mov BH,busNumber
mov BL,functionNumber
mov DI,RegisterNumber
int 1Ah
jc @noaction
mov res,cx
mov okay,true
@noaction:
db 66h;
popa
end;

result:=res;
readPCIRegisterWord:=okay;
end;


function readPCIRegisterDWord(RegisterNumber:word;BusNumber:Byte;FunctionNumber:Byte;var result:longint):boolean;
var okay:boolean;
res:longint;
begin

okay:=false;
res:=0;
asm
db 66h;
pusha
mov AX,0B10ah
mov BH,busNumber
mov BL,functionNumber
mov DI,RegisterNumber
int 1Ah
jc @noaction
db 66h;
mov word ptr res,cx { MOV RES, ECX }
mov okay,true
@noaction:
db 66h;
popa
end;

result:=res;
readPCIRegisterDword:=okay;
end;


function writePCIRegisterByte(RegisterNumber:word;BusNumber:Byte;FunctionNumber:Byte;input:byte):boolean;
var okay:boolean;
begin

okay:=false;
asm
db 66h;
pusha
mov AX,0B10bh
mov BH,busNumber
mov BL,functionNumber
mov DI,RegisterNumber
mov CL,input
int 1Ah
jc @noaction
mov okay,true
@noaction:
db 66h;
popa
end;

writePCIRegisterByte:=okay;
end;


function writePCIRegisterWord(RegisterNumber:word;BusNumber:Byte;FunctionNumber:Byte;input:word):boolean;
var okay:boolean;
begin

okay:=false;
asm
db 66h;
pusha
mov AX,0B10ch
mov BH,busNumber
mov BL,functionNumber
mov DI,RegisterNumber
mov CX,input
int 1Ah
jc @noaction
mov okay,true
@noaction:
db 66h;
popa
end;

writePCIRegisterWord:=okay;
end;


function writePCIRegisterDWord(RegisterNumber:word;BusNumber:Byte;FunctionNumber:Byte;input:longint):boolean;
var okay:boolean;
res:byte;
begin

okay:=false;
res:=0;
asm
db 66h;
pusha
mov AX,0B10dh
mov BH,busNumber
mov BL,functionNumber
mov DI,RegisterNumber
db 66h;
mov CX, word ptr input
int 1Ah
jc @noaction
mov okay,true
@noaction:
db 66h;
popa
end;

writePCIRegisterDWord:=okay;
end;


end.

{ DUTILS - Turbo Pascal UTILITIES }
{ (c) 1994 by Dieter Pawelczak }

{$R-}
{$D+}
{$S-}
unit DUTILS;
interface
usesdo
S,crt;
const { Month names and number of days - used to display the date }
MonthStr: array[1..12] of string[3] = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun','Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
DayStr: Array[0..6] of String[3] = ('Su.','Mo.','Tu.','We.','Th.','Fr.','Sa.');
MonatStr: array[1..12] of string[3] = ('Jan', 'Feb', 'Mar', 'Apr', 'Mai', 'Jun','Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez');
TagStr: Array[0..6] of String[3] = ('So.','Mo.','Di.','Mi.','Do.','Fr.','Sa.');
MonthLen: Array[1..12] of Byte=(31,28,31,30,31,30,31,31,30,31,30,31);

var
Path: PathStr;
scrtyp:Word;


(* File - Procedures *)

procedure copyfile(Source,Dest:String);
function Filelength(pth:string):LongInt;
procedure IsExt(VAR Filename:String;Ext:String);
FUNCTION GetExefilesize(Exename:String): LONGINT;
function getprgdir(prg:string):String;(* read directory of prg file *)
function fileexist(fn:String):Boolean;

(* CRT routines *)

procedure cursoroff;
procedure cursoron;

procedure color(ccl,cch:Byte);
(* color (Fore -,background) *)
function Bigletters(bl:String):String;(* German upcase *)


Procedure Twin(x1,y1,x2,y2:Byte);
Procedure Twin2(x1,y1,x2,y2:Byte);
(*do
uble *)
Procedure Twin1(x1,y1,x2,y2:Byte);
(* Single *)
Procedure Cwin2(x1,y1,x2,y2,attr:Byte);
(*do
uble with colour attributes *)
Procedure Cwin1(x1,y1,x2,y2,attr:Byte);
(* single *)
Procedure tback;
(* draw background *)
procedure shad(xx,yy:WORD);
procedure print(x1,y1:word;t:string);(* print with no attributes *)
procedure cprint(x1,y1:word;t:string;attr:byte);(* print with attributes *)

(* Number Conversions *)

procedure twodecout(xx:real);
procedure hexout(xx:word);
(* print hex number *)
function bins16(xx:word):String;
function bins8(xx:byte):String;
function bins(xx:longint):String;
function hexs(xx:longint):String;
function hexs8(xx:byte):String;
function hexs16(xx:word):String;
function twodecs(xx:real):String;
(* convert real to string *)
function decs(xx:longint;format:Byte):String;(* convert integer to String *)
function hextodec(s:string):longint;(* convert Hex to Longint *)

(* Date and Time *)

function getweekday(d,m,y:word):integer;
(* d-day m-month y-year *)
function date(typ:boolean):String;
(* convert date to string *)
procedure stime;
(* show time *)
function time:String;
(* get time HH.MM.SS *)
function timeexact:String;
(* get time HH.MM.SS.hh *)

(* Keyboard *)

function shiftpressed:Boolean;
function strpressed:Boolean;
function Altpressed:Boolean;
function altgrpressed:Boolean;




implementation


function shiftpressed:Boolean;
var std:byte;
begin

asm
mov ah,2;
int 16h
mov std,al
end;

shiftpressed:=(std and 1=1)or(std and 2=2);
end;


function strpressed:Boolean;
var std:byte;
begin

asm
mov ah,2;
int 16h
mov std,al
end;

strpressed:=(std and 4=4);
end;


function Altpressed:Boolean;
var std:byte;
begin

asm
mov ah,2;
int 16h
mov std,al
end;

Altpressed:=(std and 8=8);
end;


function altgrpressed:Boolean;
var std:byte;
begin

asm
mov ah,12h;
int 16h
mov std,ah
end;

altgrpressed:=(std and 8=8);
end;






function getweekday(d,m,y:word):integer;
var h1,s:longint;
ii:Byte;
iss:boolean;

begin

iss:=false;
if y mod 4=0 then
iss:=true;
if y mod 100=0 then
if (y mod 400<>0) then
iss:=false;
s:=0;
if y>1 then
s:=(y-1) div 4-(y div 100)+(y div 400);
h1:=y+s;
if m>1 then
for ii:=1 to m-1do
h1:=h1+longint(Monthlen[ii]);
if m>2 then
if iss then
h1:=h1+1;
h1:=h1+d;
getweekday:=h1 mod 7;
end;


function date(Typ:Boolean):String;
VAR yy,mm,dd,dw:WORD;
TG:String;
begin

getdate(yy,mm,dd,dw);
if not typ then
tg:=TagStr[dw] else
tg:=daystr[dw];
date:=tg+', '+decs(dd,2)+'.'+decs(mm,2)+'.'+decs(yy,4);
end;


function time:String;
VAR hh,mm,ss,dw:WORD;
TG,TI:String;
begin

gettime(hh,mm,ss,dw);
ti:=decs(mm,2);
if ti[1]=' ' then
ti[1]:='0';
tg:=decs(hh,2)+'.'+ti;
ti:=decs(ss,2);
if ti[1]=' ' then
ti[1]:='0';
tg:=tg+'.'+ti;time:=tg;
end;


function timeexact:String;
VAR hh,mm,ss,dw:WORD;
TG,TI:String;
begin

gettime(hh,mm,ss,dw);
ti:=decs(mm,2);
if ti[1]=' ' then
ti[1]:='0';
tg:=decs(hh,2)+'.'+ti;
ti:=decs(ss,2);
if ti[1]=' ' then
ti[1]:='0';
tg:=tg+'.'+ti;
ti:=decs(dw,2);
if ti[1]=' ' then
ti[1]:='0';
tg:=tg+'.'+ti;timeexact:=tg;
end;


{$I-}
function fileexist(fn:String):Boolean;
var ff:text;
i:integer;
begin

i:=ioresult;
Assign(ff,fn);reset(ff);
if ioresult=0 then

begin
close(ff);
fileexist:=true end else
fileexist:=false;


end;


function single(s:char):longint;
var i:longint;
begin

if ord(s)>58 then
i:=ord(s)-55 else
i:=ord(s)-48;
single:=i;
end;


function hextodec(s:string):longint;
var i:longint;
begin

s:=bigletters(s);
if pos('$',s)=1 then
s:=copy(s,2,length(s)-1);
while s[length(s)]=' 'do
s:=copy(s,1,length(s)-1);
i:=0;
while length(s)<>0
do
begin

if length(s)=5 then
i:=i+65536*single(s[1]);
if length(s)=4 then
i:=i+4096*single(s[1]);
if length(s)=3 then
i:=i+256*single(s[1]);
if length(s)=2 then
i:=i+16*single(s[1]);
if length(s)=1 then
i:=i+single(s[1]);
s:=copy(s,2,length(s)-1);
end;

hextodec:=i;
end;


procedure cprint(x1,y1:word;t:string;attr:byte);
var h2,h3:WORD;
begin

t:=t+#0;
h2:=ofs(t)+1;
h3:=seg(t);
asm
push ds
push es
push si
push di
mov ax,h3
mov es,ax
mov ax,y1
dec ax
mov dx,$00A0
mul dx
mov bx,ax
mov ax,x1
dec ax
shl ax,1
add ax,bx
mov di,ax
mov si,h2
mov ax,ScrTyp;
mov ds,ax;
mov bh,attr
@002:
mov bl,es:[si]
cmp bl,0
je @003
moV ds:[di],bx
inc di
inc di
inc si
jmp @002
@003:
pop di
pop si
pop es
pop ds
end;

end;

procedure print(x1,y1:word;t:string);
var h2,h3:WORD;
begin

t:=t+#0;
h2:=ofs(t)+1;
h3:=seg(t);
asm
push ds
push es
push si
push di
mov ax,h3
mov es,ax
mov ax,y1
dec ax
mov dx,$00A0
mul dx
mov bx,ax
mov ax,x1
dec ax
shl ax,1
add ax,bx
mov di,ax
mov si,h2
mov ax,ScrTyp;
mov ds,ax;
@002:
mov bl,es:[si]
cmp bl,0
je @003
moV ds:[di],bl
inc di
inc di
inc si
jmp @002
@003:
pop di
pop si
pop es
pop ds
end;

end;


procedure color(ccl,cch:Byte);
begin

textcolor(ccl);TextBackground(cch);
end;


function NumStr(N, D: Integer): String;
begin

NumStr[0] := Chr(D);
while D > 0do

begin

NumStr[D] := Chr(N mod 10 + Ord('0'));
N := N div 10;
Dec(D);
end;

end;


function getprgdir(prg:string):String;
var nam:Namestr;
ext:Extstr;
pthathstr;
umg:dirstr;
s:string;
begin

s:=FSEARCH(prg,'*.*');
if s='' then
s:=FSearch(prg,getenv('PATH'));
pth:=s;
Fsplit(pth,umg,nam,ext);
getprgdir:=umg;
end;


procedure IsExt(VAR Filename:String;Ext:String);
begin

if pos('.',Filename)=0 then
Filename:=Filename+Ext;
end;


function Filelength(pth:string):LongInt;
var i:longint;
fi:file;
begin

{$I-}
assign(fi,pth);reset(fi,1);i:=0;
IF IOResult=0 then
i:=FileSize(fi);
{$I+}
close(fi);
Filelength:=i;
end;




procedure stime;
var
hour,min,sec,sec100:word;
z:string[3];
zeit:string[10];

begin

gettime(hour,min,sec,sec100);
zeit:='';
str(hour,z);
if hour<10 then
z:='0'+z;
zeit:=z+':';
str(min,z);
if min<10 then
z:='0'+z;
zeit:=zeit+z+':';
str(sec,z);
if sec<10 then
z:='0'+z;
zeit:='<'+zeit+z+'>';
print(70,25,zeit);
end;

function Bigletters(bl:String):String;
var i:Byte;
begin

for i:=1 to length(bl)do

begin

if (bl>='a') and (bl<='z') then
bl:=CHR(ord(bl)-32);
if bl='? then
bl:='?;
if bl='? then
bl:='?;
if bl='? then
bl:='?;
end;

Bigletters:=bl;
end;






Procedure Shad(xx,yy:Word);
begin

if xx<>80 then

asm
mov ax,ScrTyp;
mov es,ax
mov ax,yy
mov dx,160
mul dx
mov bx,ax
mov ax,xx
mov dx,2
mul dx
add ax,bx
mov di,ax
mov al,es:[di]
cmp al,$B2
jne @002
mov al,$B0
mov es:[di],al
@002:
end;

end;


Procedure Twin(x1,y1,x2,y2:Byte);
var b,c,d:String[80];
i:Byte;
begin

b:='';c:='';d:='';
if y2>25 then
y2:=25;
if x2>80 then
x2:=80;
for i:=x1 to x2-2do

begin

b:=b+chr(32);d:=d+'?;
end;

c:='?+d+'?;gotoxy(x1,y1);write(c);
b:='?+b+'?;
for i:=y1 to y2-2do

begin

gotoxy(x1,i+1);write(b);
end;

c:='?+d+'?;gotoxy(x1,y2);write(c);
end;

Procedure Twin2(x1,y1,x2,y2:Byte);
var b,c,d:String[80];
i:Byte;
begin

b:='';c:='';d:='';
if y2>25 then
y2:=25;
if x2>80 then
x2:=80;
for i:=x1 to x2-2do

begin

b:=b+chr(32);d:=d+'?;
end;

c:='?+d+'?;gotoxy(x1,y1);write(c);shad(x2,y1);
b:='?+b+'?;
for i:=y1 to y2-2do

begin

gotoxy(x1,i+1);write(b);shad(x2,i+1);
end;

c:='?+d+'?;gotoxy(x1,y2);write(c);
for i:=x1+1 to x2do
shad(i,y2);
end;

Procedure Twin1(x1,y1,x2,y2:Byte);
var b,c,d:String[80];
i:Byte;
begin

b:='';c:='';d:='';
if y2>25 then
y2:=25;
if x2>80 then
x2:=80;
for i:=x1 to x2-2do

begin

b:=b+chr(32);d:=d+'?;
end;

c:='?+d+'?;shad(x2,y1-1);shad(x2,y1);
gotoxy(x1,y1);write(c);
b:='?+b+'?;
for i:=y1 to y2-2do

begin

gotoxy(x1,i+1);write(b);shad(x2,i+1);
end;

c:='?+d+'?;
gotoxy(x1,y2);write(c);
for i:=x1+1 to x2do
shad(i,y2);
end;

Procedure Cwin2(x1,y1,x2,y2,attr:Byte);
var b,c,d:String[80];
i:Byte;
begin

b:='';c:='';d:='';
if y2>24 then
y2:=24;
if x2>80 then
x2:=80;
for i:=x1 to x2-2do

begin

b:=b+chr(32);d:=d+'?;
end;

c:='?+d+'?;cprint(x1,y1,c,attr);shad(x2,y1);
b:='?+b+'?;
for i:=y1 to y2-2do

begin

cprint(x1,i+1,b,attr);shad(x2,i+1);
end;

c:='?+d+'?;cprint(x1,y2,c,attr);
for i:=x1+1 to x2do
shad(i,y2);
end;

Procedure Cwin1(x1,y1,x2,y2,attr:Byte);
var b,c,d:String[80];
i:Byte;
begin

b:='';c:='';d:='';
if y2>24 then
y2:=24;
if x2>80 then
x2:=80;
for i:=x1 to x2-2do

begin

b:=b+chr(32);d:=d+'?;
end;

c:='?+d+'?;shad(x2,y1-1);shad(x2,y1);
cprint(x1,y1,c,attr);
b:='?+b+'?;
for i:=y1 to y2-2do

begin

cprint(x1,i+1,b,attr);shad(x2,i+1);
end;

c:='?+d+'?;
cprint(x1,y2,c,attr);
for i:=x1+1 to x2do
shad(i,y2);
end;


Procedure TBack;
begin

asm
mov ax,ScrTyp;
mov es,ax
mov di,160
mov al,$B2
@001:
mov es:[di],al
inc di
inc di
cmp di,3840
jb @001
end;

end;

function twodecs(xx:real):String;
var h1,h2,h3:longint;
s,ss:String[8];
begin

xx:=xx*100;
h1:=trunc(xx);
h2:=h1 div 100;
h3:=h1 mod 100;
if h3<0 then
h3:=-h3;
str(h2,ss);
str(h3,s);
if h3<10 then
s:='0'+s;
twodecs:=ss+'.'+s;
end;


procedure twodecout(xx:real);
begin

write(twodecs(xx));
end;

procedure hexout(xx:word);
begin

write(hexs(xx));
end;

function decs(xx:longint;format:Byte):String;
var s:string[10];
begin

str(xx,s);
while length(s)<formatdo
s:=' '+s;
decs:=s;
end;


function hexs(xx:longint):String;
var ss:String[8];
h1,h2:Byte;
begin

ss:='';
h1:=32;
repeat
dec(h1,4);
h2:=(xx shr h1) and $f;
if h2>9 then
h2:=h2+7;
h2:=h2+48;
ss:=ss+chr(h2);
until h1=0;
hexs:=ss;
end;


function hexs16(xx:word):String;
var ss:String[8];
h1,h2:Byte;
begin

ss:='';
h1:=16;
repeat
dec(h1,4);
h2:=(xx shr h1) and $f;
if h2>9 then
h2:=h2+7;
h2:=h2+48;
ss:=ss+chr(h2);
until h1=0;
hexs16:=ss;
end;


function hexs8(xx:byte):String;
var ss:String[8];
h1,h2:Byte;
begin

ss:='';
h1:=8;
repeat
dec(h1,4);
h2:=(xx shr h1) and $f;
if h2>9 then
h2:=h2+7;
h2:=h2+48;
ss:=ss+chr(h2);
until h1=0;
hexs8:=ss;
end;



function bins(xx:longint):String;
var ss:String[32];
h1,h2:Byte;
begin

ss:='';
h1:=32;
repeat
dec(h1);
h2:=(xx shr h1) and $1;
h2:=h2+48;
ss:=ss+chr(h2);
until h1=0;
bins:=ss;
end;


function bins16(xx:word):String;
var ss:String[32];
h1,h2:Byte;
begin

ss:='';
h1:=16;
repeat
dec(h1);
h2:=(xx shr h1) and $1;
h2:=h2+48;
ss:=ss+chr(h2);
until h1=0;
bins16:=ss;
end;


function bins8(xx:byte):String;
var ss:String[32];
h1,h2:Byte;
begin

ss:='';
h1:=8;
repeat
dec(h1);
h2:=(xx shr h1) and $1;
h2:=h2+48;
ss:=ss+chr(h2);
until h1=0;
bins8:=ss;
end;


procedure copyfile(Source,Dest:String);
var FROMF, TOF:FILE;
Numread,Numwrite:WORD;
BUF:array[0..3071] of CHAR;
var ds,ss:String;
begin

ds:=Dest;ss:=source;
if (ds='') then
ds:=copy(ss,1,pos('.',ss))+'bak';
assign(FRomF,Source);Reset(FROMF,1);
assign(TOF,Ds);Rewrite(ToF,1);
writeLn('Copy file(s):'+Source+' to:'+dest);
repeat
Blockread(FromF,Buf,SizeOf(Buf),Numread);
Blockwrite(TOF,Buf,Numread,Numwrite);
until (Numread=0) or (Numwrite<>Numread) or (Numread<>SizeOF(BUF));
Close(Fromf);
Close(Tof);
end;


FUNCTION GetExefilesize(Exename:String): LONGINT;
VAR
ExeFile: FILE OF BYTE;
IDByte : ARRAY[1..2] OF BYTE;
g : ARRAY[1..4] OF BYTE;
g1,g2,g3,g4:longint;
Ioerror:integer;
begin

Assign(ExeFile, ExeName);
Reset(ExeFile);
IOError := IOResult;
IF IOError <> 0 then
exit;
Read(ExeFile, IDByte[1]);
Read(ExeFile, IDByte[2]);
IF (Chr(IDByte[1]) = 'M') AND (Chr(IDByte[2]) = 'Z') then

begin
(* EXE *)
Read(ExeFile, g[1]);g1:=g[1];
Read(ExeFile, g[2]);g2:=g[2];
Read(ExeFile, g[3]);g3:=g[3];
Read(ExeFile, g[4]);g4:=g[4];
Close(ExeFile);
IF (g[1] = 0) AND (g[2] = 0) then

Getexefilesize :=
g4 * 256 + g3
else

Getexefilesize :=
(g4 * 256 + g3 - 1) * 512 + (g2 * 256 +
g1);
END
else

Getexefilesize := 0;
end;


procedure cursoroff;
assembler;
asm
mov AH,01h
mov CH,32
mov CL,1
int 10h
end;


procedure cursoron;
assembler;
asm
mov AH,01h
mov CH,0
mov CL,1
int 10h
end;


begin

ScrTyp:=$B800;Randomize;
if Byte(Ptr($40,$49)^)=7 then
ScrTyp:=$b000;
end.

好象有很多错误，而且应该在2000下无法运行