////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Direct CPU I/O port access for user mode applications.                     //
// Uses freeware giveio.sys driver written by Dale Roberts.                   //
// Note: direct I/O assess is potentially dangerous, you may hang system,     //
//  if will not be careful. But if direct I/O takes about 1.8/2.5/3.9 mks     //
//  per byte/word/dword I/O, "right" kernel mode driver, via call of          //
//  DeviceIoControl, will takes at least 30 mks.                              //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20011211 - Creation & test Ok.                                             //
// 20230622 - Modified for FPC (A.K.)                                         //
// 20250129 - Use TAtomicCounter                                              //
////////////////////////////////////////////////////////////////////////////////

unit _crw_pio; // port input/output

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

{$IFDEF CPU32}
{$WARN 4079 off : Converting the operands to "$1" before doing the add could prevent overflow errors.}
{$ENDIF ~CPU32}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 {$IFDEF WINDOWS} jwawinsvc, {$ENDIF}
 {$IFDEF UNIX}{$IF DEFINED(CPU86) or DEFINED(CPUX86_64)} x86, {$ENDIF}{$ENDIF}
 sysutils, classes,
 _crw_alloc, _crw_proc, _crw_str, _crw_fio, _crw_fifo;

 {
 ******************************************************************************
 Purpose:
   Port[...]  is Borland Pascal - like array to access byte  CPU port I/O.
   PortW[...] is Borland Pascal - like array to access word  CPU port I/O.
   PortL[...] is Borland Pascal - like array to access dword CPU port I/O.
 Note:
  1) Before use port I/O, you need call IOPM_Open, see below.
  1) You should not create/destroy Port,PortW,PortL, system do it automatically.
 Example:
   program IOPM_Test;
   uses _pio;
   begin
    if IOPM_Open('giveio.sys') and IOPM_CheckIO then begin
     Port[$300]:=Port[$300]+1;
     PortW[$301]:=PortW[$301] and $F000;
     PortL[$310]:=PortL[$310] or $80000000;
     // & etc.
    end;
    IOPM_Close;
   end;
 ******************************************************************************
 }
type
 TBasePort = class(TLatch)
 private
  myErrors : TAtomicCounter;
  function  GetErrors:SizeInt;
  procedure SetErrors(aErrors:SizeInt);
  function  IncErrors:SizeInt;
 public
  property  Errors:SizeInt read GetErrors write SetErrors;
 public
  constructor Create;
  destructor  Destroy; override;
 end;
 TBytePort = class(TBasePort)
 private
  procedure SetPort(Address:LongInt; Data:Byte);
  function  GetPort(Address:LongInt):Byte;
 public
  property  ByteIO[Address:LongInt]:Byte read GetPort write SetPort;  default;
 end;
 TWordPort = class(TBasePort)
 private
  procedure SetPort(Address:LongInt; Data:Word);
  function  GetPort(Address:LongInt):Word;
 public
  property  WordIO[Address:LongInt]:Word read GetPort write SetPort;  default;
 end;
 TLongPort = class(TBasePort)
 private
  procedure SetPort(Address:LongInt; Data:LongInt);
  function  GetPort(Address:LongInt):LongInt;
 public
  property  LongIO[Address:LongInt]:LongInt read GetPort write SetPort;  default;
 end;

function Port:TBytePort;
function PortB:TBytePort;
function PortW:TWordPort;
function PortL:TLongPort;

 {
 ******************************************************************************
 Purpose:
   This functions uses to give access to direct port I/O under Windows 9x/NT/2k.
   IOPM         - "Input / Output Permission Map"
   IOPM_CheckIO - try to read some port to check direct I/O access.
   IOPM_Open    - open the IOPM driver to enable direct I/O access.
                  FileName is name of driver, if Section='' or Variable=''.
                  FileName is name of config file, if Section<>'' and Variable<>''.
                  Section is name of config file section where driver path placed.
                  Variable is name of driver path variable in this section.
                  For example:
                   IOPM_Open('example.cfg','[IOPM]','DriverPath')
                  where example.cfg contains:
                   [IOPM]
                   DriverPath = c:\winnt\system32\driver\giveio.sys
   IOPM_Close   - close the IOPM driver to free memory and disable port I/O.
   IOPM_History - history of IOPM driver work for diagnostic reasons.
 Note:
   If IOPM_Open called once, direct I/O access enabled until program stop
   execution. IOPM_Close only free memory and set internal flag off.
 ******************************************************************************
 }
const
 IOPM_DEVICE_NAME  = 'giveio';
 IOPM_DISPLAY_NAME = 'CPU port I/O permission map driver.';

function  IOPM_CheckIO:Boolean;
function  IOPM_Opened:Boolean;
function  IOPM_Permitted(Address,Num:LongInt):Boolean;
function  IOPM_Permit(From,Num:Cardinal; Enable:Boolean):Boolean;
function  IOPM_Open(const FileName : LongString = IOPM_DEVICE_NAME;
                    const Section  : LongString = '';
                    const Variable : LongString = ''):Boolean;
procedure IOPM_Close;
function  IOPM_History:LongString;

{$IFDEF WINDOWS}
 {
 *******************************************************************************
 Purpose:
   TSysDriverLoader encapsulate *.SYS driver loader functions.
   To load and start *.SYS driver, we have to:
    1) Open Service Control Manager
    2) Install driver via Service Control Manager, if driver was not already installed.
    3) Start the driver via Service Control Manager, if driver was not already started.
    4) Open device via CreateFile('\\.\DriverName'...) call.
   To stop working, we have to:
    1) Close device.
    2) Stop driver, if driver was not already started.
    3) Uninstall driver, if driver was not already installed.
    4) Close Service Control Manager.
 *******************************************************************************
 }
type
 TSysDriverLoader = class(TLatch)
 protected
  myManager             : SC_HANDLE;            { Handle for Service Control Manager }
  myDevice              : SC_HANDLE;            { Handle for device }
  myDriverName          : TParsingBuffer;       { The name of driver }
  myDriverPath          : TParsingBuffer;       { Full driver path }
  myDisplayName         : TParsingBuffer;       { Driver short description }
  myStatus              : DWORD;                { Status of last operation }
  myHistory             : TText;                { History of loading }
  myWasAlreadyInstalled : Boolean;              { Driver was installed? }
  myWasAlreadyStarted   : Boolean;              { Driver was started? }
  myStayResident        : Boolean;              { Don't uninstall service }
  myStayRunning         : Boolean;              { Don't stop service }
  procedure   Annals(const aMsg:LongString; aCod:DWORD);
  function    OpenServiceControlManager:DWORD;
  function    CloseServiceControlManager:DWORD;
  function    InstallService:DWORD;
  function    StartService:DWORD;
  function    StopService:DWORD;
  function    KillService:DWORD;
  function    OpenDevice:DWORD;
  function    CloseDevice:DWORD;
 public
  constructor Create(const TheDriverPath  : LongString;
                     const TheDisplayName : LongString = '';
                           StayResident   : Boolean = false;
                           StayRunning    : Boolean = false);
  destructor  Destroy; override;
  function    OpenDriver:Boolean;
  procedure   CloseDriver;
  function    History:LongString;
 end;

const
 THE_IOPM_DRIVER : TSysDriverLoader = nil;
{$ENDIF WINDOWS}

 {
 ******************************************************************************
 PC speaker sound routines with direct port I/O. Uses ports $42,$43,$61
 ******************************************************************************
 }
procedure SoundOn(wFrequency : Word);
procedure SoundOff;
procedure Sound(wFrequency : Word; wDelay : LongWord);
procedure PlayGreetingSound;

implementation

type // Uses for IO port permission bit map
 TPortMap=packed array[0..1024*8-1] of Byte;

procedure PortMapClear(var Map:TPortMap; Filler:Byte=0);
begin
 SafeFillChar(Map,SizeOf(Map),Filler);
end;

function PortMapPerm(const Map:TPortMap):Boolean;
var i:Integer;
begin
 Result:=false;
 for i:=Low(Map) to High(Map) do begin
  if (Map[i]<>0) then Result:=true;
  if Result then Break;
 end;
end;

function PortMapGet(const Map:TPortMap; Address:Word):Boolean;
var ByteIndex:Word; BitNumber,BitMask:Byte;
begin
 ByteIndex:=(Address shr 3);
 BitNumber:=(Address and 7);
 BitMask:=(1 shl BitNumber);
 Result:=((Map[ByteIndex] and BitMask)<>0);
end;

procedure PortMapSet(var Map:TPortMap; Address:Word; Enable:Boolean);
var ByteIndex:Word; BitNumber,BitMask:Byte;
begin
 ByteIndex:=(Address shr 3);
 BitNumber:=(Address and 7);
 BitMask:=(1 shl BitNumber);
 if Enable
 then Map[ByteIndex]:=Map[ByteIndex] or      BitMask
 else Map[ByteIndex]:=Map[ByteIndex] and not BitMask;
end;

var
 IOPM:record    // IO Permission Map
  Perm:Boolean; // Any port(s) permitted
  Map:TPortMap; // Bit Map of permitted ports
 end;

function IOPM_Permitted(Address,Num:LongInt):Boolean;
begin
 Result:=False;
 if not IOPM.Perm then Exit;
 if (Address<Low(Word)) then Exit;
 if (Address>High(Word)) then Exit;
 while (Num>0) do begin
  Result:=PortMapGet(IOPM.Map,Address);
  if not Result then Exit;
  Inc(Address);
  Dec(Num);
 end;
end;

 {
 ************************
 TBasePort implementation
 ************************
 }
constructor TBasePort.Create;
begin
 inherited Create;
 LockedInit(myErrors);
end;

destructor TBasePort.Destroy;
begin
 LockedFree(myErrors);
 inherited Destroy;
end;

function  TBasePort.GetErrors:SizeInt;
begin
 if Assigned(Self) then Result:=LockedGet(myErrors) else Result:=0;
end;

procedure TBasePort.SetErrors(aErrors:SizeInt);
begin
 if Assigned(Self) then LockedExchange(myErrors,aErrors);
end;

function  TBasePort.IncErrors:SizeInt;
begin
 if Assigned(Self) then Result:=LockedInc(myErrors) else Result:=0;
end;

 {
 ************************
 TBytePort implementation
 ************************
 }
function TBytePort.GetPort(Address:LongInt):Byte;
begin
 Result:=0;
 if not IOPM_Permitted(Address,SizeOf(Byte)) then begin IncErrors; Exit; end;
 {$IF DEFINED(CPU86) or DEFINED(CPUX86_64)}
 Result:=fpc_x86_inportb(Address);
 {$ENDIF}
end;

procedure TBytePort.SetPort(Address:LongInt; Data:Byte);
begin
 if not IOPM_Permitted(Address,SizeOf(Byte)) then begin IncErrors; Exit; end;
 {$IF DEFINED(CPU86) or DEFINED(CPUX86_64)}
 fpc_x86_outportb(Address,Data);
 {$ENDIF}
end;

 {
 ************************
 TWordPort implementation
 ************************
 }
function TWordPort.GetPort(Address:LongInt):Word;
begin
 Result:=0;
 if not IOPM_Permitted(Address,SizeOf(Word)) then begin IncErrors; Exit; end;
 {$IF DEFINED(CPU86) or DEFINED(CPUX86_64)}
 Result:=fpc_x86_inportw(Address);
 {$ENDIF}
end;

procedure TWordPort.SetPort(Address:LongInt; Data:Word);
begin
 if not IOPM_Permitted(Address,SizeOf(Word)) then begin IncErrors; Exit; end;
 {$IF DEFINED(CPU86) or DEFINED(CPUX86_64)}
 fpc_x86_outportw(Address,Data);
 {$ENDIF}
end;

 {
 ************************
 TLongPort implementation
 ************************
 }
function TLongPort.GetPort(Address:LongInt):LongInt;
begin
 Result:=0;
 if not IOPM_Permitted(Address,SizeOf(LongInt)) then begin IncErrors; Exit; end;
 {$IF DEFINED(CPU86) or DEFINED(CPUX86_64)}
 Result:=fpc_x86_inportl(Address);
 {$ENDIF}
end;

procedure TLongPort.SetPort(Address:LongInt; Data:LongInt);
begin
 if not IOPM_Permitted(Address,SizeOf(LongInt)) then begin IncErrors; Exit; end;
 {$IF DEFINED(CPU86) or DEFINED(CPUX86_64)}
 fpc_x86_outportl(Address,Data);
 {$ENDIF}
end;

 {
 ************************************
 IOPM driver functions implementation
 ************************************
 }
function IOPM_CheckIO:Boolean;
var Perm:Boolean;
begin
 Result:=false;
 try
  Perm:=IOPM_Permitted($61,1);
  try
   if IOPM_Permit($61,1,true) then begin
    // Try read speaker port. Exception means IO disabled.
    if (PortB[$61]>0) then Result:=true else Result:=true;
   end;
  finally
   IOPM_Permit($61,1,Perm);
  end;
 except
  on E: EPrivilege do Result:=false;       // If exception raised,
  on E: EAccessViolation do Result:=false; // direct I/O disabled.
 end;
end;

function  IOPM_Opened:Boolean;
begin
 Result:=IOPM.Perm;
end;

function  IOPM_Open(const FileName : LongString = IOPM_DEVICE_NAME;
                    const Section  : LongString = '';
                    const Variable : LongString = ''):Boolean;
{$IFDEF WINDOWS}
var DriverPath:LongString;
{$ENDIF WINDOWS}
begin
 IOPM_Close;
 {$IFDEF WINDOWS}
 if (Win32Platform = VER_PLATFORM_WIN32_NT) then begin
  if IsEmptyStr(Section) or IsEmptyStr(Variable)
  then DriverPath:=UnifyFileAlias(SmartFileRef(FileName,'.sys',ProgName))
  else if not ReadIniFilePath(FileName,Section,Variable,HomeDir,DriverPath) then DriverPath:='';
  THE_IOPM_DRIVER:=TSysDriverLoader.Create(DriverPath,IOPM_DISPLAY_NAME,false,false);
  Result:=THE_IOPM_DRIVER.OpenDriver;
  { Don't need driver after enable direct I/O access for THIS process }
  THE_IOPM_DRIVER.CloseDriver;
 end else Result:=true;
 if Result then begin
  PortMapClear(IOPM.Map,$FF);
  IOPM.Perm:=true;
 end;
 {$ENDIF WINDOWS}
 {$IFDEF UNIX}
 Result:=IsIamRoot; // Only root can permit IO Ports
 {$ENDIF UNIX}
end;

procedure IOPM_Close;
begin
 IOPM.Perm:=false;
 PortMapClear(IOPM.Map);
 {$IFDEF WINDOWS}
 Kill(TObject(THE_IOPM_DRIVER));
 {$ENDIF WINDOWS}
end;

{$IFDEF WINDOWS}
// Sinulate Linux IOPerm.
function fpIOperm(From,Num:Cardinal; Value:Integer):Integer;
begin
 Result:=1;
 if (Num>0) then
 if (From<=High(Word)) then
 if (From+Num-1<=High(Word)) then
 if Assigned(THE_IOPM_DRIVER) then Result:=0;
end;
{$ENDIF WINDOWS}

function IOPM_Permit(From,Num:Cardinal; Enable:Boolean):Boolean;
var i:Cardinal;
begin
 Result:=false;
 if (Num<=0) then Exit;
 if (fpIOPerm(From,Num,Ord(Enable))=0) then begin
  for i:=0 to Num-1 do PortMapSet(IOPM.Map,From+i,Enable);
  Result:=true; IOPM.Perm:=PortMapPerm(IOPM.Map);
 end;
end;

function  IOPM_History:LongString;
begin
 Result:='';
 {$IFDEF WINDOWS}
 if (Win32Platform=VER_PLATFORM_WIN32_NT) then begin
  if Assigned(THE_IOPM_DRIVER)
  then Result:=THE_IOPM_DRIVER.History
  else Result:='IOPM driver not assigned.';
 end else Result:='Under Windows 95/98 IOPM driver does not need.';
 {$ENDIF WINDOWS}
end;

{$IFDEF WINDOWS}
 {
 *******************************
 TSysDriverLoader implementation
 *******************************
 }
constructor TSysDriverLoader.Create(const TheDriverPath  : LongString;
                                    const TheDisplayName : LongString = '';
                                          StayResident   : Boolean = false;
                                          StayRunning    : Boolean = false);
begin
 inherited Create;
 myManager:=0;
 myDevice:=INVALID_HANDLE_VALUE;
 StrCopyBuff(myDriverName,UnifyAlias(ExtractFileName(TheDriverPath)));
 StrCopyBuff(myDriverPath,UnifyFileAlias(SmartFileRef(TheDriverPath,'.SYS',ProgName)));
 StrCopyBuff(myDisplayName,TheDisplayName);
 if StrLen(myDisplayName)=0 then StrLCopy(myDisplayName,myDriverName,SizeOf(myDisplayName)-1);
 myStatus:=ERROR_SUCCESS;
 myHistory:=NewText;
 myWasAlreadyInstalled:=false;
 myWasAlreadyStarted:=false;
 myStayResident:=StayResident;
 myStayRunning:=StayRunning;
end;

destructor TSysDriverLoader.Destroy;
begin
 CloseDriver;
 Kill(myHistory);
 inherited Destroy;
end;

function TSysDriverLoader.OpenDriver:Boolean;
begin
 Result:=false;
 if Assigned(Self) then begin
  if myDevice <> INVALID_HANDLE_VALUE then CloseDevice;
  if myManager <> 0 then CloseServiceControlManager;
  Result := (OpenServiceControlManager = ERROR_SUCCESS) and
            (myManager <> 0) and
            (InstallService = ERROR_SUCCESS) and
            (StartService = ERROR_SUCCESS) and
            (OpenDevice = ERROR_SUCCESS) and
            (myDevice <> INVALID_HANDLE_VALUE);
 end;
end;

procedure TSysDriverLoader.CloseDriver;
begin
 if Assigned(Self) then begin
  if myDevice <> INVALID_HANDLE_VALUE then CloseDevice;
  OpenServiceControlManager;
  if myManager <> 0 then begin
   if not (myWasAlreadyStarted or myStayRunning) then StopService;
   if not (myWasAlreadyInstalled or myStayResident) then KillService;
   CloseServiceControlManager;
  end;
 end;
end;

function TSysDriverLoader.History:LongString;
begin
 Result:='';
 if Assigned(Self) then Result:=myHistory.Text;
end;

procedure TSysDriverLoader.Annals(const aMsg:LongString; aCod:DWORD);
begin
 myStatus:=aCod;
 myHistory.AddLn(Pad(aMsg,30)+' Err='+d2s(aCod,-5)+' Msg='+SysErrorMessage(aCod));
end;

function TSysDriverLoader.OpenServiceControlManager:DWORD;
const
 SC_MANAGER_USERS_ACCESS = SC_MANAGER_CONNECT or SC_MANAGER_QUERY_LOCK_STATUS or SC_MANAGER_ENUMERATE_SERVICE;
 SC_MANAGER_ADMIN_ACCESS = SC_MANAGER_CONNECT or SC_MANAGER_QUERY_LOCK_STATUS or SC_MANAGER_ENUMERATE_SERVICE or SC_MANAGER_CREATE_SERVICE;
begin
 Result := ERROR_SUCCESS;
 if myManager = 0 then begin
  myManager := jwawinsvc.OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if (myManager=0) and (GetLastError=ERROR_ACCESS_DENIED)
  then myManager := jwawinsvc.OpenSCManager(nil, nil, SC_MANAGER_ADMIN_ACCESS);
  if (myManager=0) and (GetLastError=ERROR_ACCESS_DENIED)
  then myManager := jwawinsvc.OpenSCManager(nil, nil, SC_MANAGER_USERS_ACCESS);
  if myManager=0 then Result:=GetLastError;
 end;
 Annals('OpenServiceControlManager:',Result);
end;

function TSysDriverLoader.CloseServiceControlManager:DWORD;
begin
 Result:=ERROR_SUCCESS;
 if myManager <> 0 then
 if not jwawinsvc.CloseServiceHandle(myManager) then Result:=GetLastError;
 myManager:=0;
 Annals('CloseServiceControlManager:',Result);
end;

function TSysDriverLoader.InstallService:DWORD;
var
 hService : SC_HANDLE;
begin
 Result:=ERROR_SUCCESS;
 { Is the driver already installed in the ServiceControlManager? }
 hService:=jwawinsvc.OpenService(myManager, myDriverName, SERVICE_QUERY_STATUS);
 if (hService<>0) then begin   { Driver already installed }
  myWasAlreadyInstalled:=true;
  if not jwawinsvc.CloseServiceHandle(hService) then Result:=GetLastError;
  Annals('InstallDriver(already installed):',Result);
 end else begin                { No driver installed, add to SCM database }
  hService := jwawinsvc.CreateService(myManager, myDriverName, myDisplayName,
                     SERVICE_ALL_ACCESS,
                     SERVICE_KERNEL_DRIVER, SERVICE_DEMAND_START,
                     SERVICE_ERROR_NORMAL, myDriverPath, nil, nil, nil, nil, nil);
  if (hService=0) and (GetLastError=ERROR_ACCESS_DENIED) then
  hService := jwawinsvc.CreateService(myManager, myDriverName, myDisplayName,
                     SERVICE_START or SERVICE_STOP or SERVICE_DELETE or SERVICE_QUERY_STATUS,
                     SERVICE_KERNEL_DRIVER, SERVICE_DEMAND_START,
                     SERVICE_ERROR_NORMAL, myDriverPath, nil, nil, nil, nil, nil);
  if hService = 0
  then Result := GetLastError
  else if not jwawinsvc.CloseServiceHandle(hService)
  then Result:=GetLastError;
  Annals('DriverInstall:',Result);
 end;
end;

function TSysDriverLoader.StartService:DWORD;
var
 hService            : SC_HANDLE;
 lpServiceArgVectors : PChar;
 sStatus             : TServiceStatus;
begin
 Result:=ERROR_SUCCESS;
 lpServiceArgVectors := nil;
 SafeFillChar(sStatus,SizeOf(sStatus),0);
 hService:=jwawinsvc.OpenService(myManager, myDriverName, SERVICE_QUERY_STATUS);
 if hService<>0 then begin
  if jwawinsvc.QueryServiceStatus(hService, sStatus) then begin
   if sStatus.dwCurrentState=SERVICE_RUNNING then myWasAlreadyStarted:=true else begin
    jwawinsvc.CloseServiceHandle(hService);
    hService := jwawinsvc.OpenService(myManager, myDriverName, SERVICE_START);
    if not jwawinsvc.StartService(hService, 0, lpServiceArgVectors) then Result:=GetLastError;
   end;
  end else Result:=GetLastError;
  if not jwawinsvc.CloseServiceHandle(hService) then Result:=GetLastError;
 end else Result:=GetLastError;
 Annals('DriverStart:',Result);
end;

function TSysDriverLoader.StopService:DWORD;
var
 hService      : SC_HANDLE;
 serviceStatus : TServiceStatus;
begin
 Result := ERROR_SUCCESS;
 if not myWasAlreadyStarted then begin
  SafeFillChar(serviceStatus,SizeOf(serviceStatus),0);
  hService := jwawinsvc.OpenService(myManager, myDriverName, SERVICE_STOP or SERVICE_QUERY_STATUS);
  if hService <> 0 then begin
   if not jwawinsvc.ControlService(hService, SERVICE_CONTROL_STOP, serviceStatus)
   then Result := GetLastError;
   if not jwawinsvc.CloseServiceHandle(hService) then Result := GetLastError;
  end else Result := GetLastError;
 end;
 Annals('DriverStop:',Result);
end;

function TSysDriverLoader.KillService:DWORD;
var
 hService : SC_HANDLE;
begin
 //StopService;
 Result:= ERROR_SUCCESS;
 if not myWasAlreadyInstalled then begin
  hService := jwawinsvc.OpenService(myManager, myDriverName, SERVICE_DELETE);
  if hService <> 0 then begin
   if not jwawinsvc.DeleteService(hService) then Result := GetLastError;
   if not jwawinsvc.CloseServiceHandle(hService) then Result := GetLastError;
  end else Result := GetLastError;
 end;
 Annals('DriverRemove:',Result);
end;

function TSysDriverLoader.OpenDevice:DWORD;
var buff:TParsingBuffer;
begin
 Result := ERROR_SUCCESS;
 if myDevice <> INVALID_HANDLE_VALUE then CloseDevice;
 myDevice := CreateFile(StrCopyBuff(buff,'\\.\'+myDriverName),    { lpFileName: PChar  }
                        GENERIC_READ or GENERIC_WRITE,            { dwDesiredAccess: integer     }
                        0,                                        { dwShareMode: Integer         }
                        nil,                                      { lpSecurityAttributes         }
                        OPEN_EXISTING,                            { dwCreationDisposition: DWORD }
                        FILE_ATTRIBUTE_NORMAL,                    { dwFlagsAndAttributes: DWORD  }
                        0);                                       { hTemplateFile: THandle       }
 if myDevice = INVALID_HANDLE_VALUE then Result := GetLastError;
 Annals('DeviceOpen:',Result);
end;

function TSysDriverLoader.CloseDevice:DWORD;
begin
 Result := ERROR_SUCCESS;
 if myDevice <> INVALID_HANDLE_VALUE then
 if not CloseHandle(myDevice) then Result := GetLastError;
 myDevice := INVALID_HANDLE_VALUE;
 Annals('DeviceClose:',Result);
end;
{$ENDIF WINDOWS}

 {
 ****************************************
 PC speaker routines uses direct port I/O
 ****************************************
 }
procedure SoundOn(wFrequency:Word);
const QuartzFrequency=1193180.0;
var wTone:Word;
begin
 if (wFrequency>0) then begin
  wTone:=Round(QuartzFrequency/wFrequency);
  Port[$61]:=Port[$61] or $03;
  Port[$43]:=$B6;
  Port[$42]:=Lo(wTone);
  Port[$42]:=Hi(wTone);
 end;
end;

procedure SoundOff;
begin
 Port[$61]:=(Port[$61] and $FC);
end;

procedure Sound(wFrequency:Word; wDelay:LongWord);
begin
 SoundOn(wFrequency);
 Sleep(wDelay);
 SoundOff;
end;

procedure PlayGreetingSound;
var i:Integer;
begin
 if IOPM_Permitted($61,1) then
 if IOPM_Permitted($42,2) then
 for i:=0 to 5 do Sound(1000*(10-i),50);
end;

///////////////////////////////////////
// The instances of Port, PortW, PortL.
///////////////////////////////////////
const
 ThePortB : TBytePort = nil;
 ThePortW : TWordPort = nil;
 ThePortL : TLongPort = nil;

function Port:TBytePort;
begin
 if not Assigned(ThePortB) then begin
  ThePortB:=TBytePort.Create;
  ThePortB.Master:=@ThePortB;
 end;
 Result:=ThePortB;
end;

function PortB:TBytePort;
begin
 if not Assigned(ThePortB) then begin
  ThePortB:=TBytePort.Create;
  ThePortB.Master:=@ThePortB;
 end;
 Result:=ThePortB;
end;

function PortW:TWordPort;
begin
 if not Assigned(ThePortW) then begin
  ThePortW:=TWordPort.Create;
  ThePortW.Master:=@ThePortW;
 end;
 Result:=ThePortW;
end;

function PortL:TLongPort;
begin
 if not Assigned(ThePortL) then begin
  ThePortL:=TLongPort.Create;
  ThePortL.Master:=@ThePortL;
 end;
 Result:=ThePortL;
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_pio;
begin
 IOPM.Perm:=false;
 PortMapClear(IOPM.Map);
 PortB.Ok; PortW.Ok; PortL.Ok;
end;

procedure Free_crw_pio;
begin
 Kill(TObject(ThePortB));
 Kill(TObject(ThePortW));
 Kill(TObject(ThePortL));
 IOPM_Close;
end;

initialization

 Init_crw_pio;

finalization

 Free_crw_pio;

end.

//////////////
// END OF FILE
//////////////

