////////////////////////////////////////////////////////////////////////////////
// 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:                                                                   //
// PKK4 CAMAC controller support.                                             //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20040811 - Creation. Need to be tested with real hardware.                 //
// 20230622 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_pkk4; // PKK4 CAMAC controller support

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

{$WARN 5023 off : Unit "$1" not used in $2}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 {$IFDEF WINDOWS} registry, {$ENDIF}
 sysutils, classes,
 _crw_alloc, _crw_pio, _crw_rtc, _crw_proc;

 ///////////////////////////////////////////////////////////////////////////////
 // Class TPkk4 encapsulate PKK4 ISA CAMAC controller features.
 // TPkk4 have no public procedures & functions, only properties.
 // Function arguments-------------Comment------------------Range---------------
 //  R                           - PKK Register,            0..7
 //  C                           - CAMAC Crate,             1..4
 //  N                           - CAMAC station Number,    1..25
 //  A                           - CAMAC module subAddress, 0..15
 //  F                           - CAMAC function,          0..31
 // Construction/destruction----------------------------------------------------
 //  * NewPkk4(Base,Irq)         - general way to create new PKK4 instance.
 //     pkk:=NewPkk4($100,9);    - create new PKK4 instance.
 //  * Kill(pkk)                 - general way to destroy PKK4 instance.
 //     Kill(pkk);               - destroy PKK4 instance.
 //  Note:
 //     Create(Base,Irq),Destroy is for internal use only.
 // General CAMAC features------------------------------------------------------
 //  * BaseAddr is base PKK4 hardware I/O address, one of $100,$180,$280,$300.
 //     Addr:=pkk.BaseAddr         - Get hardware I/O address
 //     pkk.BaseAddr:=$100         - Set hardware I/O address
 //  * IrqNumber is hardware PKK4 IRQ number, one of 5,7,9,10,11,12,15.
 //     Irq:=pkk.IrqNumber         - Get hardware IRQ number
 //     pkk.IrqNumber:=9           - Set hardware IRQ number
 //  * Declare[C] checks, if PKK4 and crate C is present and operable.
 //     if pkk[1] then ...         - PKK4 controller and crate 1 is operable.
 //     if pkk.Declare[1] then ... - Just the same.
 //  * Registers[C,R] gives R/W access to PKK4 word registers. Be very care!
 //     CSR:=pkk.Registers[1,5]    - read  status register CSR of crate 1.
 //     pkk.Registers[1,7]:=1;     - write LAM mask register of crate 1.
 //  * CNAF[C,N,A,F] is general CAMAC NAF command without data read/write.
 //    pkk.CNAF[1,2,0,8]           - NAF,crate=1,station=2,subaddr.=0,func.=8
 //    if not pkk.CNAF[C,N,A,F]... - then invalid
 //  * CNAF16[C,N,A,F] is CAMAC NAF command with 16 bit data read/write.
 //     data:=pkk.CNAF16[C,N,A,F]; - NAF and read  16 bit data word.
 //     pkk.CNAF16[C,N,A,F]:=data; - NAF and write 16 bit data word.
 //  * CNAF24[C,N,A,F] is CAMAC NAF command with 24 bit data read/write.
 //     data:=pkk.CNAF24[C,N,A,F]; - NAF and read  24 bit data word.
 //     pkk.CNAF24[C,N,A,F]:=data; - NAF and write 24 bit data word.
 //  * I[C] is CAMAC I signal, Inhibit, available for read and write.
 //     pkk.I[C]:=true;            - set Inhibit signal for crate C.
 //     Inhibit:=pkk.I[C];         - get Inhibit signal status.
 //  * X[C],Q[C],XQ[C] is CAMAC X,Q and (X and Q) signal status, for read only.
 //     if pkk.XQ[1] then ...       - check if CAMAC X and Q signal is on.
 //  * Z[C],C[C] is CAMAC Z (Zero) and C (Clear) signals, for write only.
 //     pkk.Z[1]:=true;             - send CAMAC Zero  signal for crate 1.
 //     pkk.C[1]:=true;             - send CAMAC Clear signal for crate 1.
 // Routines for LAM/interrupts-------------------------------------------------
 //  * LamMask[C] is LAM enable mask, for read and write. To enable/disable LAM
 //    request (and maybe interrupt) for station 1..14, set bit 0..13 to 1/0.
 //     pkk.LamMask[1]:=3;          - enable LAM for 1 and 2 station of crate 1.
 //     if pkk.LamMask[1] and 4     - then LAM for station=3,crate=1 is enabled.
 //  * LamWord[C] is LAM request word, for read only. LAM word bit 0..13 will be
 //    1/0 if was/not LAM for station 1..14.
 //     if pkk.LamWord[1] and 4<>0  - then LAM requested for station=3,crate=1.
 //  * IrqMask[C] is read/write property to enable/disable hardware interrupts.
 //    To enable/disable LAM/X/Q interrupt, set 0/1/2 bit of mask to 0/1.
 //    LAM interrupt generated when and only both LamMask and IrqMask bits is 1.
 //    So for LAM interrupts, LamMask also need to be enabled/disabled.
 //     pkk.IrqMask[1]:=1;          -  Enable LAM interrupt for crate 1.
 //     pkk.IrqMask[1]:=0;          -  Disable all interrupts for crate 1.
 //     pkk.IrqMask[1]:=0;          -  Also uses to clear interrupt request.
 //     if pkk.IrqMask[1] and 1<>0  -  then LAM interrupt enabled.
 //  * IrqWord[C] is read only property to recognize reason of interrupt.
 //    If bit 0/1/2 of IrqWord is 1, LAM/X/Q interrupt request is really occured.
 //     if pkk.IrqWord[1] and 1<>0  - then LAM request took place for crate 1.
 //                                   Use LamWord[1] to recognize LAM source.
 //  * SaveRegs[C] is read/write property to save/restore 24 bit read and write
 //    PKK4 registers in a single operation. Usefull for interrupt handlers.
 //     regs:=pkk.SaveRegs[1];      - save PKK registers before IRQ handling.
 //     pkk.SaveRegs[1]:=regs;      - restore PKK registers after IRQ handling.
 // Notes-----------------------------------------------------------------------
 //  1) Current CRW32 version does not support hardware interrupts for PKK4.
 //     So strongly forbidden to use IrqMask[C]:=n with n<>0 to enable IRQ.
 //     If you enable interrupts, it may hang or crash you computer!
 //  2) For the same reason, be care with CSR register. You should never set
 //     CSR bits 11/12/13 to 1, because it enables LAM/X/Q interrupts.
 //  3) For hardware port I/O, GIVEIO.SYS driver uses, see _pio.pas unit.
 //  4) To start GIVEIO.SYS driver, ADMINISTRATOR rights needed.
 ///////////////////////////////////////////////////////////////////////////////
type
 TPkk4NanoSleepProc = procedure(ns:Double);           // Wait for ns nanoseconds
 TPkk4=class(TMasterObject)                           // PKK4 CAMAC controller
 private                                              // Private data:
  myBaseAddr  : Cardinal;                             // Hardware base I/O address
  myIrqNumber : Cardinal;                             // Hardware IRQ number
  myNanoSleep : TPkk4NanoSleepProc;                   // Delay procedure
 private                                              // Private methods:
  function    SuitableB(B:Cardinal):Boolean;          // Check base address
  function    SuitableI(I:Cardinal):Boolean;          // Check IRQ number
  function    SuitableC(C:Cardinal):Boolean;          // Check crate number
  function    SuitableCR(C,R:Cardinal):Boolean;       // Check crate & register
  function    SuitableCNAF(C,N,A,F:Cardinal):Boolean; // Check C,N,A,F
  function    GetBaseAddr:Cardinal;
  procedure   SetBaseAddr(aBaseAddr:Cardinal);
  function    GetIrqNumber:Cardinal;
  procedure   SetIrqNumber(aIrqNumber:Cardinal);
  procedure   SetNanoSleepProc(aNanoSleepProc:TPkk4NanoSleepProc);
  function    GetDeclare(C:Cardinal):Boolean;
  function    GetRegisters(C,R:Cardinal):Cardinal;
  procedure   SetRegisters(C,R,aRegister:Cardinal);
  function    GetCNAF(C,N,A,F:Cardinal):Boolean;
  function    GetCNAF16(C,N,A,F:Cardinal):Cardinal;
  procedure   SetCNAF16(C,N,A,F,aW16:Cardinal);
  function    GetCNAF24(C,N,A,F:Cardinal):Cardinal;
  procedure   SetCNAF24(C,N,A,F,aW24:Cardinal);
  function    GetI(C:Cardinal):Boolean;
  procedure   SetI(C:Cardinal;aI:Boolean);
  function    GetX(C:Cardinal):Boolean;
  function    GetQ(C:Cardinal):Boolean;
  function    GetXQ(C:Cardinal):Boolean;
  procedure   SetZ(C:Cardinal;aZ:Boolean);
  procedure   SetC(C:Cardinal;aC:Boolean);
  function    GetLamMask(C:Cardinal):Cardinal;
  procedure   SetLamMask(C,aLamMask:Cardinal);
  function    GetLamWord(C:Cardinal):Cardinal;
  function    GetSaveRegs(C:Cardinal):Int64;
  procedure   SetSaveRegs(C:Cardinal;aSaveRegs:Int64);
  function    GetIrqMask(C:Cardinal):Cardinal;
  procedure   SetIrqMask(C,aIrqMask:Cardinal);
  function    GetIrqWord(C:Cardinal):Cardinal;
 public ///// Routines for construction/destruction, for internal use only. ////
  constructor Create(aBaseAddr,aIrqNumber:Cardinal);
  destructor  Destroy; override;
 public ///// Routines for general CAMAC features. /////////////////////////////
  property    BaseAddr                 : Cardinal read GetBaseAddr  write SetBaseAddr;
  property    IrqNumber                : Cardinal read GetIrqNumber write SetIrqNumber;
  property    Declare[C:Cardinal]      : Boolean  read GetDeclare;  default;
  property    Registers[C,R:Cardinal]  : Cardinal read GetRegisters write SetRegisters;
  property    CNAF[C,N,A,F:Cardinal]   : Boolean  read GetCNAF;
  property    CNAF16[C,N,A,F:Cardinal] : Cardinal read GetCNAF16    write SetCNAF16;
  property    CNAF24[C,N,A,F:Cardinal] : Cardinal read GetCNAF24    write SetCNAF24;
  property    I[C:Cardinal]            : Boolean  read GetI         write SetI;
  property    X[C:Cardinal]            : Boolean  read GetX;
  property    Q[C:Cardinal]            : Boolean  read GetQ;
  property    XQ[C:Cardinal]           : Boolean  read GetXQ;
  property    Z[C:Cardinal]            : Boolean                    write SetZ;
  property    C[C:Cardinal]            : Boolean                    write SetC;
 public ///// Routines for LAM/interrupts. IrqMask is currently forbidden! /////
  property    LamMask[C:Cardinal]      : Cardinal read GetLamMask   write SetLamMask;
  property    LamWord[C:Cardinal]      : Cardinal read GetLamWord;
  property    IrqMask[C:Cardinal]      : Cardinal read GetIrqMask   write SetIrqMask;
  property    IrqWord[C:Cardinal]      : Cardinal read GetIrqWord;
  property    SaveRegs[C:Cardinal]     : Int64    read GetSaveRegs  write SetSaveRegs;
 public
  procedure   NanoSleep(ns:Double=-1); 
  property    NanoSleepProc            : TPkk4NanoSleepProc         write SetNanoSleepProc;
 end;

function  NewPkk4(aBaseAddr:Cardinal=$100; aIrqNum:Cardinal=9):TPkk4;
procedure Kill(var TheObject:TPkk4); overload;

const                                  // Pkk4 uses address space size:
 Pkk4AddrSpaceSize = 8*SizeOf(Word)*4; // 8 Registers[Word] * 4 Crates.

const
 Pkk4NanoSleepDefault : Double = 100;
 Pkk4NanoCoeff        : Double = 0;

procedure DefaultPkk4NanoSleepProc(ns:Double);

implementation

const
 regNAF   = 0; // Register to write NAF
 regW16   = 1; // Register to write  0..15 data bits
 regW24   = 2; // Register to write 16..23 data bits
 regR16   = 3; // Register to read   0..15 data bits
 regR24   = 4; // Register to read  16..23 data bits
 regCSR   = 5; // Register to read/wrire CSR
 regINT   = 6; // Register to read  LAM interrupt request map
 regMASK  = 7; // Register to write LAM interrupt mask

 ///////////////////////////////////////////////////////////////////////////////
 // PKK4 construction/destruction
 ///////////////////////////////////////////////////////////////////////////////
constructor TPkk4.Create(aBaseAddr,aIrqNumber:Cardinal);
begin
 inherited Create;
 BaseAddr:=aBaseAddr;
 IrqNumber:=aIrqNumber;
 NanoSleepProc:=DefaultPkk4NanoSleepProc;
end;

destructor TPkk4.Destroy;
begin
 inherited Destroy;
end;

function TPkk4.SuitableB(B:Cardinal):Boolean;
begin
 if Assigned(Self)
 then Result:=(B=$100) or (B=$180) or (B=$280) or (B=$300)
 else Result:=false;
end;

function TPkk4.SuitableI(I:Cardinal):Boolean;
begin
 if Assigned(Self)
 then Result:=(I in [5,7,9,10,11,12,15])
 else Result:=false;
end;

function TPkk4.SuitableC(C:Cardinal):Boolean;
begin
 if Assigned(Self)
 then Result:=(C-1<4)
 else Result:=false;
end;

function TPkk4.SuitableCR(C,R:Cardinal):Boolean;
begin
 if Assigned(Self)
 then Result:=(C-1<4) and (R<8)
 else Result:=false;
end;

function TPkk4.SuitableCNAF(C,N,A,F:Cardinal):Boolean;
begin
 if Assigned(Self)
 then Result:=(C-1<4) and (N-1<25) and (A<16) and (F<32)
 else Result:=false;
end;

function TPkk4.GetBaseAddr:Cardinal;
begin
 if Assigned(Self) then Result:=myBaseAddr else Result:=0;
end;

procedure TPkk4.SetBaseAddr(aBaseAddr:Cardinal);
begin
 if SuitableB(aBaseAddr) then begin
  myBaseAddr:=aBaseAddr;
  IOPM_Permit(aBaseAddr,Pkk4AddrSpaceSize,true);
 end;
end;

function TPkk4.GetIrqNumber:Cardinal;
begin
 if Assigned(Self) then Result:=myIrqNumber else Result:=0;
end;

procedure TPkk4.SetIrqNumber(aIrqNumber:Cardinal);
begin
 if SuitableI(aIrqNumber) then myIrqNumber:=aIrqNumber;
end;

procedure TPkk4.NanoSleep(ns:Double);
begin
 if Assigned(Self) then
 if Assigned(myNanoSleep) then begin
  if (ns<0) then ns:=Pkk4NanoSleepDefault;
  myNanoSleep(ns);
 end;
end;

procedure TPkk4.SetNanoSleepProc(aNanoSleepProc:TPkk4NanoSleepProc);
begin
 if Assigned(Self) then myNanoSleep:=aNanoSleepProc;
end;

function TPkk4.GetDeclare(C:Cardinal):Boolean;
begin
 Result:=false;
 if SuitableC(C) then begin
  Registers[C,regCSR]:=$C000;
  if ((Registers[C,regCSR] and $C000)=0) then Exit;
  Registers[C,regMASK]:=$AAA;
  if ((Registers[C,regMASK] and $0FFF)<>$AAA) then Exit;
  Result:=true;
 end;
end;

function TPkk4.GetRegisters(C,R:Cardinal):Cardinal;
begin
 if SuitableCR(C,R) then begin
  NanoSleep;
  Result:=PortW[myBaseAddr+((C-1) shl 4)+(R shl 1)];
  NanoSleep;
 end else Result:=0;
end;

procedure TPkk4.SetRegisters(C,R,aRegister:Cardinal);
begin
 if SuitableCR(C,R) then begin
  NanoSleep;
  PortW[myBaseAddr+((C-1) shl 4)+(R shl 1)]:=aRegister;
  NanoSleep;
 end;
end;

function TPkk4.GetCNAF(C,N,A,F:Cardinal):Boolean;
begin
 Result:=false;
 if SuitableCNAF(C,N,A,F) then begin
  Registers[C,regNAF]:=(N shl 9) or (A shl 5) or F;
  Result:=true;
 end;
end;

function TPkk4.GetCNAF16(C,N,A,F:Cardinal):Cardinal;
begin
 Result:=0;
 if SuitableCNAF(C,N,A,F) then begin
  Registers[C,regNAF]:=(N shl 9) or (A shl 5) or F;
  Result:=Registers[C,regR16];
 end;
end;

procedure TPkk4.SetCNAF16(C,N,A,F,aW16:Cardinal);
begin
 if SuitableCNAF(C,N,A,F) then begin
  Registers[C,regW16]:=aW16;
  Registers[C,regNAF]:=(N shl 9) or (A shl 5) or F;
 end;
end;

function TPkk4.GetCNAF24(C,N,A,F:Cardinal):Cardinal;
begin
 Result:=0;
 if SuitableCNAF(C,N,A,F) then begin
  Registers[C,regNAF]:=(N shl 9) or (A shl 5) or F;
  LongRec(Result).Lo:=Registers[C,regR16];
  LongRec(Result).Hi:=Registers[C,regR24] and $FF;
 end;
end;

procedure TPkk4.SetCNAF24(C,N,A,F,aW24:Cardinal);
begin
 if SuitableCNAF(C,N,A,F) then begin
  Registers[C,regW16]:=LongRec(aW24).Lo;
  Registers[C,regW24]:=LongRec(aW24).Hi and $FF;
  Registers[C,regNAF]:=(N shl 9) or (A shl 5) or F;
 end;
end;

function TPkk4.GetI(C:Cardinal):Boolean;
begin
 Result:=(Registers[C,regCSR] and 4 = 4);
end;

procedure TPkk4.SetI(C:Cardinal;aI:Boolean);
begin
 if aI
 then Registers[C,regCSR]:=Registers[C,regCSR] or      Cardinal(8)
 else Registers[C,regCSR]:=Registers[C,regCSR] and not Cardinal(8);
end;

function TPkk4.GetX(C:Cardinal):Boolean;
begin
 Result:=(Registers[C,regCSR] and 1 = 1);
end;

function TPkk4.GetQ(C:Cardinal):Boolean;
begin
 Result:=(Registers[C,regCSR] and 2 = 2);
end;

function TPkk4.GetXQ(C:Cardinal):Boolean;
begin
 Result:=(Registers[C,regCSR] and 3 = 3);
end;

procedure TPkk4.SetZ(C:Cardinal;aZ:Boolean);
begin
 if aZ then Registers[C,regCSR]:=$10;
end;

procedure TPkk4.SetC(C:Cardinal;aC:Boolean);
begin
 if aC then Registers[C,regCSR]:=$20;
end;

function TPkk4.GetLamMask(C:Cardinal):Cardinal;
begin
 Result:=Registers[C,regMASK];
end;

procedure TPkk4.SetLamMask(C,aLamMask:Cardinal);
begin
 Registers[C,regMASK]:=aLamMask;
end;

function TPkk4.GetLamWord(C:Cardinal):Cardinal;
begin
 Result:=Registers[C,regINT];
end;

function TPkk4.GetIrqMask(C:Cardinal):Cardinal;
begin
 Result:=(Registers[C,regCSR] shr 11) and 7;
end;

procedure TPkk4.SetIrqMask(C,aIrqMask:Cardinal);
begin
 Registers[C,regCSR]:=(Registers[C,regCSR] and $C7FF) or ((aIrqMask and 7) shl 11);
end;

function TPkk4.GetIrqWord(C:Cardinal):Cardinal;
begin
 Result:=(Registers[C,regCSR] shr 8) and 7;
end;

function TPkk4.GetSaveRegs(C:Cardinal):Int64;
begin
 if SuitableC(C)
 then Result:=Int64(Registers[C,regW16])+
              Int64(Registers[C,regW24]) shl 16 +
              Int64(Registers[C,regR16]) shl 32 +
              Int64(Registers[C,regR24]) shl 48
 else Result:=0;
end;

procedure TPkk4.SetSaveRegs(C:Cardinal;aSaveRegs:Int64);
begin
 if SuitableC(C) then begin
  Registers[C,regW16]:=aSaveRegs;
  Registers[C,regW24]:=aSaveRegs shr 16;
  Registers[C,regR16]:=aSaveRegs shr 32;
  Registers[C,regR24]:=aSaveRegs shr 48;
 end;
end;

function  NewPkk4(aBaseAddr:Cardinal=$100; aIrqNum:Cardinal=9):TPkk4;
begin
 Result:=nil;
 try
  Result:=TPkk4.Create(aBaseAddr,aIrqNum);
 except
  on E:Exception do BugReport(E,nil,'NewPkk4');
 end;
end;

procedure Kill(var TheObject:TPkk4); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end;
end;

procedure DefaultPkk4NanoSleepProc(ns:Double);
var t:Int64;
begin
 if (ns>0) then
 if (Pkk4NanoCoeff>0) then
 try
  t:=RDTSC;
  while (abs(RDTSC-t)*Pkk4NanoCoeff<=ns) do;
 except
  Pkk4NanoCoeff:=0;  
 end;
end;

procedure InitPkk4;
begin
 Pkk4NanoCoeff:=cpu_mhz;
 if (Pkk4NanoCoeff<=0) then Pkk4NanoCoeff:=EastimateCpuFrequencyMHz(1000);
 if (Pkk4NanoCoeff>0) then Pkk4NanoCoeff:=1000.0/Pkk4NanoCoeff;
end;

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

procedure Init_crw_pkk4;
begin
 InitPkk4;
end;

procedure Free_crw_pkk4;
begin
end;

initialization

 Init_crw_pkk4;

finalization

 Free_crw_pkk4;

end.

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

