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

program INT_TEST
  { Investigate interactions of MSDOS, ROM BIOS, RTC.  See text at end. } ;
{$IFDEF  WINDOWS} Fail ; {$ENDIF}
{$IFDEF     DPMI} Fail ; {$ENDIF}
{$IFNDEF   MSDOS} Fail ; {$ENDIF}
{$IFNDEF   VER70} Fail ; {$ENDIF}

uses {$IFDEF FONT} {in lieu of Crt:} TextSet, {$ENDIF} Dos ;

const
ID='INT_TEST.PAS - www.merlyn.demon.co.uk >= 2001-01-20 12h' ;

VladoProc : boolean = true ;

DigitString : string [16] = '0123456789ABCDEF' ;
Weekdays : array [0..6] of string [3] =
  ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat') ;

Sp = #32 ;
Co1 = $3100 ; Co2 = $1F00 ; Co3 = $4E00 ;
Co4 = $0300 ; Co5 = $0F00 ; Co6 = $1A00 ;
ScreenCols = 80 ; FixedRows = 11 ;
DayTix = $1800B0 ;

RTCbot = 0 ; RTCtop = 127 ;

type S80 = string [80] ; S25 = string [30] ; S2 = string [2] ;
RTCaddr = RTCbot..RTCtop ;
RTCrec = record rCy, rYr, rMo, rDy, rHr, rMi, rSc : byte end { 2 nibbles } ;
EpochRec = record eYr, eMo, eDy, eDoW, eHr, eMi, eSc, eCs : word end ;
Plong = ^longint ;
Pword = ^word ;
PString = ^string ;

HelpList = array [2..Pred(FixedRows)] of S80 ;

const
MoreHelp : HelpList = (ID+'   Press space bar',
  ' Commands are case-independent, few abbreviations.',
  ' "<Command> ?" gives a line of command-specific Help.',
  ' "Tab" toggles input style to/from menu pick by cursor, Enter.',
  ' Options: /PS2 => PS/2; /N<number> is GlobalMax stored for RRRTC.',
  ' See also text at end of program source file, and the source itself.',
  ' Bottom line shows directly read data,'{+}
  + ' without using any MSDOS or BIOS calls :',
  '----------------------- MSDOS -----------------------'{+}
  + '  ---------- RTC ----------',
  ' Internal DayCount=>MSDOS Date, Cy+ 18.2Hz=>estimate;'{+}
  + '  Direct   Date      Time') ;
CommandList : HelpList = (
  ' BP/TP : GetTime, SetTime H M S, GetDate, SetDate Y M D;',
  ' MSDOS :   21/2C,   21/2D H M S,   21/2A,   21/2B Y M D;',
  ' BIOS  :   1A/02,   1A/03 H M S,   1A/04,   1A/05 Y M D,  1A/00,  1A/01 L;',
  ' Driver: ReadCLOCK$, WriteCLOCK$ DC H M S;',
  ' Direct: Get406C, Set406C L, GetRTC, [Hex] SetRTC Y M D H M S, PutRTCcy CC,',
  '         SetCCloc $nn, RRRTC N, TIMEDRTC H M S N, CMOSview, SetCMOSreg $nn $xx,' {...} ,
  '         SeeCLOCK$buf, PutCLOCK$buf Y M D DW DC;',
  ' Misc  : FindDayCount, Exec ... , ART N, LeapRTC, '+
  {$IFDEF FONT} 'Font, '+ {$ENDIF} 'DSB, CompRate, ReBoot;',
  ' Prog. : Tab, '#24#25', '#27#26' Ins Del Home End,' +
  ' H, Help, Q, Quit (don''t shorten)'
  ) ;

var DigitArray : array [-1..15] of char absolute DigitString ;

const
PDayCount : ^word = NIL ;
DefaultMax = 20 ;
GlobalMax : word = DefaultMax ;
DosVer : record Maj, Min : byte; BootDev : char end =
  (Maj:0; Min:0; BootDev:'@') ;
CCinCMOS : RTCaddr = $32 { Bank 1, $48 ; $7F } ;
Exe : boolean = false ;

type TClockBuf =
  record BufD, BufM : byte ; BufRY, BufDC : word ; BufDW : byte end ;

var ClockRecPtr : ^TClockBuf ;
DTApad, GetDTA, VidSeg : word ;
LastScreenRow, LastScroll, CmdLine : byte ;


(*
  procedure PushF ; inline($9C) { Push Flags } ;
  procedure PopF  ; inline($9D) { Pop  Flags -
  PopF does not restore IE in DPMI or V86 ? } ;
  procedure CLI ; inline($FA) { CLI - disable interrupts } ;
  *)

procedure STI ; inline($FB) { STI -  enable interrupts } ;
procedure DI ; inline($9C/$FA) { PushF CLI } ;
procedure EI ; inline($9D) { PopF } ;

function KeyPushed : boolean ;
begin KeyPushed := MemW[Seg0040:$001A]<>MemW[Seg0040:$001C] end ;

function GetKbd : word ; assembler ;
asm  mov AH,0 ; int 16h  end ;

procedure WaitKbd ; assembler ;
asm  mov AH,0 ; int 16h  end ;


{ Possibly one ought also to use the SET bit, the MSB of Reg B ;
  but ISTM that the wait-on-UIP will more than suffice.
  Also Bit 7 of $70, the NMI bit ??? }


procedure WaitForUIPlowCLI ;
assembler { Vlado+JRS } ;
asm
    CLI ;
  @@wait0:
    STI ; CLI                           { allow interrupts in during wait }
    mov al,0ah ; out 70h,al ; in al,71h { fix the UIP flag in bit 7 of al }
    or al,al ; js @@wait0               { loop the test if it is set }
    end {WaitForUIPlowCLI} ;


procedure WaitForUIPend ;
assembler { Vlado } ;
asm ;
  @@wait1: mov al,0ah ; out 70h,al ; in al,71h { fix UIP flag in bit 7 of al }
    or al,al ; jns @@wait1 ;                   { wait until UIP flag is set }
  @@wait0: mov al,0ah ; out 70h,al ; in al,71h { fix UIP flag in bit 7 of al }
    or al,al ; js @@wait0                      { wait until UIP flag is clear }
    end {WaitForUIPend} ;


procedure WaitForUIPendCLI ;
assembler { Vlado+JRS } ;
asm ;
  @@wait1:
    mov al,0ah ; out 70h,al ; in al,71h { fix UIP flag in bit 7 of al }
    or al,al ; jns @@wait1              { wait until UIP flag is set }
    CLI ;                               { prepare for next }
  @@wait0:
    STI ; CLI                           { allow interrupts in during wait }
    mov al,0ah ; out 70h,al ; in al,71h { fix UIP flag in bit 7 of al }
    or al,al ; js @@wait0               { wait for UIP flag clear }
    end {WaitForUIPendCLI} ;


procedure UnIntPutCMOSreg(const B : byte ; const A : RTCaddr) ;
begin WaitForUIPendCLI ; Port[$70] := A ; Port[$71] := B ; STI end ;


procedure GetRTCdirectly(var RTC : RTCrec) ;
begin WaitForUIPlowCLI ;
  with RTC do begin
    Port[$70] := CCinCMOS ; rCy := Port[$71] ;
    Port[$70] := $09 ; rYr := Port[$71] ;
    Port[$70] := $08 ; rMo := Port[$71] ;
    Port[$70] := $07 ; rDy := Port[$71] ;
    Port[$70] := $04 ; rHr := Port[$71] ;
    Port[$70] := $02 ; rMi := Port[$71] ;
    Port[$70] := $00 ; rSc := Port[$71] ;
    STI end end {GetRTCdirectly} ;


procedure PutRTCdirectly(const RTC : RTCrec) ;
begin WaitForUIPendCLI ;
  with RTC do begin
    Port[$70] := CCinCMOS ; Port[$71] := rCy ;
    Port[$70] := $09 ; Port[$71] := rYr ;
    Port[$70] := $08 ; Port[$71] := rMo ;
    Port[$70] := $07 ; Port[$71] := rDy ;
    Port[$70] := $04 ; Port[$71] := rHr ;
    Port[$70] := $02 ; Port[$71] := rMi ;
    Port[$70] := $00 ; Port[$71] := rSc ;
    STI end end {PutRTCdirectly} ;


procedure PutRTCTimeDirectly(const H, M, S : byte) ;
begin WaitForUIPendCLI ;
  Port[$70] := $04 ; Port[$71] := H ;
  Port[$70] := $02 ; Port[$71] := M ;
  Port[$70] := $00 ; Port[$71] := S ;
  STI end {PutRTCTimeDirectly} ;


procedure PutRTCcyDirectly(const Cy : byte) ;
begin WaitForUIPendCLI ; Port[$70] := CCinCMOS ; Port[$71] := Cy ; STI end ;


function Get406C : longint ;
begin DI ; Get406C := MemL[Seg0040:$006C] ; EI end ;

procedure Put406C(const X : longint)  ;
begin DI ; MemL[Seg0040:$006C] := X ; EI end ;


function NN(const n2 : byte) : S2 { n2 is BCD nibbles } ;
begin NN := DigitArray[n2 shr 4] + DigitArray[n2 and $F] end ;

function DateTimeStringRTC(const RTC : RTCrec) : S25 ;
begin with RTC do DateTimeStringRTC :=
    ' RTC: '+NN(rCy)+NN(rYr)+'-'+NN(rMo)+'-'+NN(rDy) +
    Sp+NN(rHr)+':'+NN(rMi)+':'+NN(rSc) end ;


function CC(const B : byte) : S2 ;
begin CC := DigitArray[B div 10] + DigitArray[B mod 10] end ;

function BCD(X : byte) : byte ;
begin BCD := (X div 10)*16 + (X mod 10) end ;

function DCB(X : byte) : byte ;
begin DCB := (X div 16)*10 + (X mod 16) end ;


function TimeStringDOS(const E : EpochRec) : S25 ;
begin with E do begin
    TimeStringDOS := Sp+CC(eHr)+':'+CC(eMi)+':'+CC(eSc) end end ;

function DateStringDOS(const E : EpochRec) : S25 ;
var S5 : string [5] ;
begin with E do begin Str(eYr:5, S5) ;
    DateStringDOS := S5+'-'+CC(eMo)+'-'+CC(eDy) end end ;

function DateTimeStringDOS(const E : EpochRec) : S25 ;
begin DateTimeStringDOS := ' DOS:'+DateStringDOS(E)+TimeStringDOS(E) end ;



function GetL(var St : S80) : longint ;
type Cset = set of #0..#255 ;
const All = [#0..#255] ;
function StartC(const St : S80 ; const CS : CSet) : boolean ;
begin StartC := (St>'') and (St[1] in CS) end ;
var X : longint ; Digit : Cset ; Base : word ;
begin Base := 10 ; Digit := ['0'..'9'] ; X := 0 ;
  while StartC(St, All-Digit) do begin
    if StartC(St, ['$']) then begin
      Base := 16 ; Digit := Digit+['A'..'F'] end ;
    Delete(St, 1, 1) end ;
  while StartC(St, Digit) do begin
    X := Base*X + Pred(Pos(St[1], DigitString)) ; Delete(St, 1, 1) end ;
  GetL := X end {GetL} ;

procedure Wr(const Xpos, Ypos : word ; const Ch : char ; const Co : word) ;
begin MemW[VidSeg:2*(Pred(Xpos)+ScreenCols*Ypos)] := Ord(Ch)+Co end ;

procedure WrScr(const Ypos : word ; const St : string ; const Co : word) ;
var Xpos : word ;
begin
  for Xpos := 1 to Length(St) do Wr(Xpos, Ypos, St[Xpos], Co) ;
  for Xpos := Succ(Length(St)) to ScreenCols do Wr(Xpos, Ypos, Sp, Co) ;
  end {WrScr} ;


const { cf. dateprox.pas }
BaseYr = 1972 ;
BaseMo =  3 {Mar} ;
LastMo = 14 {Feb} ;
Yrs001 = 365 ;
Yrs004 = Yrs001*4 + 1 ;

DOSBias = ( { Day 0 => 1980-01-01 }
  Yrs004*(((1980-BaseYr)        ) div 4) +
  Yrs001*(((1980-BaseYr) mod   4)      )  -31-29 + 1 ) - 0 ;

DaysInMonth : array [BaseMo..Pred(LastMo)] of byte =
  (31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31{, Feb}) ;

var DaysFromFeb : array [BaseMo..LastMo] of word ;


function YMDtoDays(Yr : integer ; Mo : byte ; const Dy : byte) : word
  { derived from DATEPROX MJDtoYMD ; for DOS days, 1980-01-01 = 0 } ;
var Days, Anni : word ;
begin
  if Mo<BaseMo then begin Inc(Mo, 12) ; Dec(Yr) end ;
  Anni := longint(Yr) - BaseYr ;
  Days := longint(Anni div 004)*Yrs004 ; Anni := Anni mod 004 ;
  Inc(Days, Anni*Yrs001) ;
  YMDtoDays := Dy + DaysFromFeb[Mo] + Days - DOSBias ;
  end {YMDtoDays} ;

procedure DaystoYMD(Days : word ; var Yr : word ; var Mo, Dy : byte)
  { derived from DATEPROX MJDtoYMD ; for DOS days, 1980-01-01 = 0 } ;
var K : word ;
begin
  Inc(Days, DOSBias-1) ; Yr := BaseYr ; Mo := BaseMo ;
  K := Days div Yrs004 ;
  Inc(Yr, K*004) ; Dec(Days, K*Yrs004) ;
  K := Days div Yrs001 ; if K>3 then K := 3 { XXXX/02/29 } ;
  Inc(Yr, K    ) ; Dec(Days, K*Yrs001) ;
  Mo := (Days shr 5) + BaseMo ;
  if (Mo<LastMo) and (DaysFromFeb[Succ(Mo)]<=Days) then Inc(Mo) ;
  Dy := Succ(Days) - DaysFromFeb[Mo] ;
  if Mo>12 then begin Dec(Mo, 12) ; Inc(Yr) end ;
  end {DaystoYMD} ;


procedure PowerOff ; assembler ;
asm { To turn PC off with APM,
    Klaus Hartnegg, "ATX board and Switch-Off", c.l.p.b, 1999-05-15. }
    mov AX,$5301 ; xor BX,BX    ;                int $15
    mov AX,$530E ; mov CX,$0101 ; xor BX,BX    ; int $15
    mov AX,$530F ; mov BX,$0001 ; mov CX,BX    ; int $15
    mov AX,$5308 ; mov BX,$0001 ; mov CX,BX    ; int $15
    mov AX,$5307 ; mov BX,$0001 ; mov CX,$0003 ; int $15
    HLT end {PowerOff} ;


procedure Wait(C : integer) ;
var T : byte ; Tkr : byte absolute $40:$6C ;
begin repeat T := Tkr ; repeat until T<>Tkr ;
    Dec(C) until C<=0 end {Wait} ;


procedure BootB { Forge CtrlAltDel } ; FAR ;
begin
  MemW[Seg0040:$001A] := MemW[Seg0040:$001C] { Empty keyboard buffer } ;
  Mem[$0040:$0017] := Mem[$0040:$0017] or $0C { 00001100, Alt Ctrl } ;
  asm ;
    mov ah,$4F { service number - needs AT } ;
    mov al,$53 { Del key's scan code } ;
    stc        { sentinel for ignoring key } ;
    Int $15 ;
    end ;
  Writeln('Failed to initiate boot') ;
  HALT end {BootB} ;

procedure BootC { soft cold boot } ; FAR ;
begin MemW[$40:$72] := $0000 ;
  Inline($EA/$00/$00/$FF/$FF) { JMP $FFFF:0000, BIOS reset } end ;

procedure BootD { soft warm boot } ; FAR ;
begin MemW[$40:$72] := $1234 ;
  Inline($EA/$00/$00/$FF/$FF) { JMP $FFFF:0000, BIOS reset } end ;

procedure BootH { PS/2 MCA Port $92 boot } ; FAR ; assembler ;
asm  in AL,$92 ;
  and AL,$FE ; out $92,AL ;
  or  AL,$01 ; out $92,AL ;
  and AL,$FE ; out $92,AL  end ;
{ Vladomir Rodriquez <assassin17@rocketmail.com>, E-mail 1999-03-01 }

procedure BootJ { dubious } ; FAR ; assembler ;
asm  int $19  end ;

procedure BootL {APM} ; FAR ;
begin PowerOff end {BootL} ;

procedure Await; FAR ; begin repeat until false end ;

procedure Nowt; FAR ; begin end ;

procedure Write66 { Amstrad PPC640 hard boot } ; FAR ;
begin Port[$66] := 0 end ;

procedure DoReBoot { from TSFAQP #49 end; not PPC640 } ; FAR ; assembler ;
{ DoReBoot may not work in non-DOS environments; probably a good thing too }
asm
    cli ;
  @@WaitOutReady:     { Busy-wait until 8042 is ready for new command}
    in al,64h         { read 8042 status byte}
    test al,00000010b { Bit 1 of status indicates input buffer full }
    jnz @@WaitOutReady
    mov al,0FEh       { Pulse "reset" = 8042 pin 0 }
    out 64h,al        { The PC will reboot now }
    HLT               (* line added by JRS after reading clax 1999-02-03 *)
    end {DoReboot} ;


const DelMask = $FFC0 ; MaxDel = 40000 ;
{ MaxDel slightly bigger than 2.38 MHz / Succ(not DelMask) }


function GetCTC : word ;
var Ans : record case byte of 0:(W : word); 1:(L,H:byte) end ;
begin DI ; Port[$43] := 0 { Latch Ch. 0 - s.7.15 } ;
  { CTC $40,40 double-decrements at 1.19 MHz - PCTIM003 s.7.16 }
  Ans.L := Port[$40] ; Ans.H := Port[$40] ; EI ;
  GetCTC := Ans.W and DelMask end {GetCTC} ;


procedure SmallWait(C : word) ;
var T : word ;
begin while C>0 do begin T := GetCTC ; repeat until T<>GetCTC ;
    Dec(C) end end {SmallWait} ;


type BootProcType = procedure ;

const
CS_='No boot' ;
CSA='Pulse RESET line' ;
CSB='AT+: forge CtrlAltDel'^G ;
CSC='Soft cold boot jump' ;
CSD='Soft warm boot jump' ;
CSE='After count, please turn PC off, wait a bit, turn it on!' ;
CSF='After count, please press Reset button!' ;
CSG='After count, please press CtrlAltDel!' ;
CSH='PS/2 MCA Port $92 boot' ;
CSI='Boot using timeswitched power' ;
CSJ='Call Int $19' ;
CSK='Some other form of non-programmed boot' ;
CSL='Power-Off using APM, Int $15 calls' ;
Str_ : string [Length(CS_)] = CS_ ;
StrA : string [Length(CSA)] = CSA ;
StrB : string [Length(CSB)] = CSB ;
StrC : string [Length(CSC)] = CSC ;
StrD : string [Length(CSD)] = CSD ;
StrE : string [Length(CSE)] = CSE ;
StrF : string [Length(CSF)] = CSF ;
StrG : string [Length(CSG)] = CSG ;
StrH : string [Length(CSH)] = CSH ;
StrI : string [Length(CSI)] = CSI ;
StrJ : string [Length(CSJ)] = CSJ ;
StrK : string [Length(CSK)] = CSK ;
StrL : string [Length(CSL)] = CSL ;
{ Boots['A'].BootProc becomes either DoReboot or Write66 }
Boots : array ['@'..'L'] of
record BootProc : BootProcType ; BootDesc : Pstring end = (
  (BootProc: Nowt; BootDesc:@Str_),
  (BootProc:  NIL; BootDesc:@StrA) {NIL gets re[placed},
  (BootProc:BootB; BootDesc:@StrB),
  (BootProc:BootC; BootDesc:@StrC),
  (BootProc:BootD; BootDesc:@StrD),
  (BootProc:Await; BootDesc:@StrE),
  (BootProc:Await; BootDesc:@StrF),
  (BootProc:Await; BootDesc:@StrG),
  (BootProc:BootH; BootDesc:@StrH),
  (BootProc:Await; BootDesc:@StrI),
  (BootProc:BootJ; BootDesc:@StrJ),
  (BootProc:Await; BootDesc:@StrK),
  (BootProc:BootL; BootDesc:@StrL) ) ;
BootSel : char = 'A' ;
BootSync : boolean = false ;
BootDelay : word = 0 ;
BootIncDel : char = #0 ;


procedure Dilate ;
var F : text ; Atts : word ; RTC : RTCrec ; Epo : EpochRec ;
Q0, Q1, XD : longint ; SQ1, SQD : string [15] ; DS, XS, S : S80 ;
K : byte ; B : boolean ; W : word ; J : integer ;
const Mark : array [boolean] of S2 = ('  ', ' *') ;
Hash : array [boolean] of char = ' #' ;
const Dlog = 'DILATION.LOG' ;
begin Writeln(^G'This may be a TD test'^G) ;

  Assign(F, DLog) ; GetFAttr(F, Atts) ;
  case DosError of
    0 : if (Atts and (AnyFile-Archive))>0
      then begin Writeln(^G'Barred by existing '+DLog) ; HALT end ;
    2 : begin ReWrite(F) ; Close(F) end ;
    else begin Writeln(^G'Something odd about '+DLog) ; HALT end ;
    end ;
  Reset(F) ;

  FillChar(XS, Length(XS), #0) ;
  while not EoF(F) do begin Readln(F, DS) ;
    if Copy(DS, 1, 5)=' RTC:' then XS := DS end ;
  Close(F) ;
  if BootIncDel in ['+', '-'] then begin Write('BootIncDel: ') ;
    Delete(DS, 1, Pos(':', DS)) ; XD := GetL(DS) ;
    Write(XD:7) ;
    if BootIncDel='-' then XD := XD - BootDelay else XD := XD + BootDelay ;
    if XD<0 then Inc(XD, MaxDel) ;
    if XD>MaxDel then Dec(XD, MaxDel) ;
    BootDelay := XD ;
    Write(XD:7) ;
    Writeln end ;

  Writeln(XS) ;
  GetRTCdirectly(RTC) ;
  with Epo do begin
    GetDate(eYr, eMo, eDy, eDoW) ; GetTime(eHr, eMi, eSc, eCs) end ;
  with Epo, RTC do
    B := (eYr<>(DCB(rCy)*100+DCB(rYr)))
    or   (eMo<>DCB(rMo)) or (eDy<>DCB(rDy))
    or   (Abs(
    (      ( longint(eHr)-longint(DCB(rHr)) )     * 60
    +      ( integer(eMi)-integer(DCB(rMi)) )  )  * 60
    +      ( integer(eSc)-integer(DCB(rSc)) )
    ) > 5 ) { Do DOS & RTC disagree in date or by > 5 seconds ? } ;

  Val(Copy(XS, 52, 12), Q0, J) ;
  with Epo do W := YMDtoDays(eYr, eMo, eDy) ;
  Q1 := (W and $3FFF {to avoid overflow})*(DayTix shr 4) + (Get406C shr 4) ;
  Str(Q1:12, SQ1) ; Str(Q1-Q0:12, SQD) ;

  S := DateTimeStringRTC(RTC) +Sp+ DateTimeStringDos(Epo) + SQ1 +SQD + Mark[B] ;

  DS := S ; for K := 1 to Length(S) do DS[K] := Hash[S[K]<>XS[K]] ;
  Writeln(DS) ; Writeln(S) ;


  with Boots[BootSel] do begin
    Append(F) ;
    Writeln(F, DS) ; Writeln(F, S) ;
    Write(F, 'Boot ', BootSel, '; ', BootDesc^, '.') ;
    if BootSync then Write(F, '  BootDelay : ', BootDelay) ;
    Writeln(F) ;
    Close(F) ;

    if Exe then begin
      Write('Type EXIT to return to INT_TEST and reboot...') ;
      Exec(GetEnv('COMSPEC'), '/k prompt='+GetEnv('PROMPT')+'$g') ;
      end ;

    asm  mov ah, $0D ; int $21  end {FlushFileBuffers} ;

    Writeln ;
    Writeln(' *** Boot', BootSel, ' - ', Pstring(BootDesc)^, ' ***') ;
    Writeln(' *** WAIT 15 seconds to let things stop -',
      ' press Space to exit ***'^G) ;
    for K := 15 downto 0 do begin Write(K:3, ^M) ; Wait(18) ;
      if KeyPushed then HALT ;
      end ;
    Writeln(' Bye!') ;
    Wait(18) ;
    UnIntPutCMOSreg(0, $0F) {1999-04-27, clear reset status} ;
    if BootSync then begin Writeln(' Syncing ', BootDelay) ;
      WaitForUIPend ; SmallWait(BootDelay) end ;
    BootProc ;
    end ;
  Writeln(' ### Did not Reboot ###') ; HALT end {Dilate} ;


procedure SetScreen ;
begin
  LastScreenRow := Mem[Seg0040:$0084] ;
  VidSeg := SegB800 ; Boots['A'].BootProc := DoReBoot ;
  if LastScreenRow<20 then begin LastScreenRow := 24 ;
    VidSeg := SegB000 ; Boots['A'].BootProc := Write66 ;
    Writeln('Assume Amstrad PPC640, mono') end ;
  LastScroll := LastScreenRow-FixedRows ;
  CmdLine := Succ(LastScroll) ;
  end {SetScreen} ;


procedure Wrte(const St : S80) ; FAR ;
begin Writeln(St) end ;

procedure Show(const St : S80) ; FAR ;
begin WrScr(LastScroll, St, Co4) end ;

procedure Scroll ;
begin Move
    (Ptr(VidSeg, 2*ScreenCols)^, Ptr(VidSeg, 0)^, LastScroll*2*ScreenCols) ;
  WrScr(LastScroll, Sp, Co3) end ;

procedure ShowUp(const St : S80) ;
begin Show(St) ; Scroll end ;

procedure UpShow(const St : S80) ;
begin Scroll ; Show(St) end ;

procedure Wipe ;
var K : byte ;
begin for K := 0 to LastScroll do Scroll end ;


procedure GoXY(X, Y : byte) { Position Cursor } ; assembler ;
asm  mov ah,$02 ; mov bh,0 ; mov dh,Y ; mov dl,X ;
  { Michael Kennedy says some old systems may need Push BP, Pop BP }
  push BP ; int $10 ; pop BP  end {GoXY} ;


{ Pedt Scragg 1999-02-06 : How about }
function CompareMemory(var block1, block2; size : word) : word ; assembler ;
asm
    mov dx,ds
    mov cx,[size]
    xor ax,ax
    jcxz @@out
    lds si,[block1]
    les di,[block2]
    cld
    repe cmpsb
    je @@out
    mov ax,[size]
    sub ax,cx ;
  @@out:
    mov ds,dx
    end {CompareMemory} ;
{ Function returns 0 if equal to size bytes or returns actual byte
  location of inequality if one is found. }
(* Pedt 1999-02-07 : CompareMemory2, wordwise *)



function Bget(var St : S80) : byte ;
begin Bget := BCD(GetL(St)) end ;

function Hex2(const X : byte) : S2 ;
begin Hex2 := DigitArray[X shr 04] + DigitArray[X and $F] end ;

function Hex4(const X : word) : S25 ;
begin Hex4 := Hex2(Hi(X)) + Hex2(Lo(X)) end ;

function PtrS(const P : pointer) : S25 ;
type OS = record O, S : word end ;
begin with OS(P) do PtrS := Hex4(S)+':'+Hex4(O) end ;

type WrProc = procedure (const St : S80) ;
var Send : WrProc ;


procedure ClockDollarCheck(const R : Registers) ;
var S : string [3] ;
begin with R do if Odd(Flags) then begin Str(AX, S) ;
    Send(' Error while using CLOCK$ driver; AX='+S+' <cr>') ;
    WaitKbd ; HALT(1) end ;
  end {ClockDollarCheck} ;

const DriverName : array [0..6] of char = 'CLOCK$'#0 ;

type TBuf = record
  DayCount : word ; Minutes, Hours, CentiSecs, Seconds : byte end ;

procedure ReadClockDollar(var Buffer : TBuf) ;
{ Adapted from C code provided in E-mail by Kris Heidenstrom }
var Handle : word ; Regs : registers ;
begin with Regs do begin

    DX := Ofs(DriverName) ; DS := Seg(DriverName) ;
    AX := $3D00 ; MsDos(Regs) ; Handle := AX ; ClockDollarCheck(Regs) ;

    DX := Ofs(Buffer) ; DS := Seg(Buffer) ; CX := 1 ; BX := Handle ;
    AX := $3F00 ; MsDos(Regs) ; ClockDollarCheck(Regs) ;

    BX := Handle ;
    AX := $3E00 ; MsDos(Regs) ;
    end {Regs} end {ReadClockDollar} ;


procedure WriteClockDollar(var Buffer : TBuf) ;
{ Adapted from C code provided in E-mail by Kris Heidenstrom }
var Handle : word ; Regs : registers ;
begin with Regs do begin

    DX := Ofs(DriverName) ; DS := Seg(DriverName) ;
    AX := $3D01 ; MsDos(Regs) ; Handle := AX ; ClockDollarCheck(Regs) ;

    DX := Ofs(Buffer) ; DS := Seg(Buffer) ; CX := 1 ; BX := Handle ;
    AX := $4000 ; MsDos(Regs) ; ClockDollarCheck(Regs) ;

    BX := Handle ;
    AX := $3E00 ; MsDos(Regs) ;
    end {Regs} end {WriteClockDollar} ;


procedure Search(const Sought, LoSeg, HiSeg, SegBot, SegTop : word) ;
var MyArea : TBuf ; PQ : ^word ; J, K : word ; B : boolean ;
begin
  Writeln('   from ', PtrS(Ptr(LoSeg, SegBot)),
    ' up to '+PtrS(Ptr(HiSeg, SegTop))) ;
  for J := LoSeg to HiSeg do for K := SegBot to SegTop do
    if MemW[J:K]=Sought then begin PQ := Ptr(J, K) ;
    Write('  Try ', PtrS(PQ), ' - changed by date?') ;
    ReadClockDollar(MyArea) ;
    Inc(MyArea.DayCount) ;
    WriteClockDollar(MyArea) ; { Sets RTC to MSDOS date/time :-( }
    B := PQ^=MyArea.DayCount ;
    Dec(MyArea.DayCount) ; WriteClockDollar(MyArea) ;
    if B then begin Write(' Yes; changes date?') ;
      Inc(PQ^) ; ReadClockDollar(MyArea) ;
      if PQ^=MyArea.DayCount then begin Write(' Yes.') ;
        if PDayCount=NIL then PDayCount := Ptr(J, K) ;
        end {=} else Write(' No.') ;
      Dec(PQ^) ;
      end {B} else Write(' No.') ;
    Writeln end {=} ;
  end {Search} ;


procedure FindDayCount(var Cmnd : S80) ; FAR ;
var AnArea : TBuf ;
begin ReadClockDollar(AnArea) ;
  with AnArea do begin
    Write(' "DayCount" value is', DayCount:6, '; ') ;
    if DayCount<100 then Writeln('too small to seek!') else begin
      Writeln(' seeking its address:') ;

      Search(DayCount, $4C, Pred(PrefixSeg), $0000, $000F) ;
      { if PDayCount=NIL then
        Search(DayCount, $FFFF, $FFFF, $0010, $FFFF) { HMA? } ;
      end end ;
  ReadClockDollar(AnArea) ;
  if PDayCount<>NIL then begin
    Writeln('  So DayCount is at ', PtrS(PDayCount)) ;
    Insert(' GetDayCount, SetDayCount DC;',
      CommandList[High(CommandList)-2], 255) ;
    end else Writeln('  DayCount NOT FOUND!'^G) ;
  end {FindDayCount} ;


procedure ShowCmnd(const Cmd : S80 ; const Co : word) ;
begin WrScr(CmdLine, Cmd, Co) ; GoXY(Length(Cmd), CmdLine) end {ShowCmnd} ;


procedure Remind(const H : HelpList) ;
var K : byte ;
begin for K := Low(H) to High(H) do
    WrScr(LastScroll+K, H[K], Co1-(Ord(K=High(H)) shl 12)) end {Remind} ;


procedure ShowTimers ;
var Q1, Q2, Q3, Q4 : string [8] ; QQ : string [20] ;
RTC : RTCrec ; Tx, Hr, Mn, Sc : longint ;
Days, YY : word ; MM, DD, OD, J : byte ;
begin GetRTCdirectly(RTC) ;
  DI ;
  Tx := MemL[Seg0040:$006C] ; OD := Mem[Seg0040:$0070] ;
  if PDayCount<>NIL then Days := PDayCount^ ;
  EI ;
  if PDayCount<>NIL then begin
    DaystoYMD(Days, YY, MM, DD) ;
    Str(Days:6, Q1) ; Str(YY:4, Q2) ;
    QQ := Q1+'=>'+Q2+'/'+CC(MM)+'/'+CC(DD) end
  else QQ := 'Daycount not found' ;
  Str(OD, Q3) ; Str(Tx:7, Q4) ;
  (* Hr := Tx div (DayTix div 24) ; Tx := Tx mod (DayTix div 24) ;
    Mn := Tx div (DayTix div 1440) ; Tx := Tx mod (DayTix div 1440) ;
    Sc := Tx div (DayTix div 86400) ;
    { Those results slightly wrong, due to rounding down in denominators;
    considered only as a general indication } *)
  Sc := (Tx*(86400 div 80)) div (DayTix div 80) { 86400 / DayTix } ;
  Mn := Sc div 60 ; Sc := Sc mod 60 ;
  Hr := Mn div 60 ; Mn := Mn mod 60 ;
  WrScr(LastScreenRow,
    'Peep:  DOS: '+ QQ+', ' +
    +Q3+'d+'+Q4+'=>'+CC(Hr)+':'+CC(Mn)+':'+CC(Sc)
    + ';  ' + DateTimeStringRTC(RTC), Co5) ;
  end {ShowTimers} ;

{ Commands : }

var Was : S80 ;
type
TaskFunc = procedure (var Cmnd : S80) ;
POpT = ^OpT ;
OpT = record Last: POpT ;
  PGen : PString ; Task : TaskFunc ; Comm : string [15] end ;


procedure NotFound(var Cmnd : S80) ; FAR ;
begin if Cmnd[1]='H' then begin Remind(MoreHelp) ;
    repeat ShowTimers until KeyPushed ;
    EXIT end else Show(Was+' Unknown Command?!') end {NotFound} ;

const
Cstr00 = 'Not a command' ;
Str00 : string [Length(Cstr00)] = Cstr00 ;
Job00 : OpT = (Last:   NIL; PGen:@Str00; Task:NotFound; Comm:'') ;

procedure GetDayCount(var Cmnd : S80) ; FAR ;
var S15 : string [15] ;
begin
  if PDayCount<>NIL then Str(PDayCount^, S15) else S15 := ' "not found"' ;
  Show(Was+S15+' days') end {GetDayCount} ;

const
Cstr01 = 'Get the actual undocumented DayCount kept in MSDOS' ;
Str01 : string [Length(Cstr01)] = Cstr01 ;
Job01 : OpT = (Last:@Job00; PGen:@Str01; Task:GetDayCount; Comm:'GETDAYCOUNT') ;

procedure PutDayCount(var Cmnd : S80) ; FAR ;
var S15 : string [15] ; J : longint ;
begin J := GetL(Cmnd) ; Str(J:6, S15) ;
  if PDayCount<>NIL then PDayCount^ := J else S15 := S15+' imposs.' ;
  Show(Was+' Set'+S15) end {PutDayCount} ;

const
Cstr02 = 'Set the actual undocumented DayCount kept in MSDOS' ;
Str02 : string [Length(Cstr02)] = Cstr02 ;
Job02 : OpT = (Last:@Job01; PGen:@Str02; Task:PutDayCount; Comm:'SETDAYCOUNT') ;

procedure Art(var Cmnd : S80) { Accelerated Rollover Test - NTP? } ; FAR ;
var N : word ; K : byte ; S6 : string [6] ;
begin N := GetL(Cmnd) ;
  WrScr(LastScroll+2,
    ' Accelerated Rollover Test : Watch the bottom of the screen!', Co1) ;
  SetDate(1999, 12, 31) ; SetTime(23, 59, 45, 0) ;
  WrScr(LastScroll+3, ' Has set 1999-12-31 23:59:45, by MSDOS', Co1) ;
  for K := 4 to Pred(FixedRows) do WrScr(LastScroll+K, '', Co1) ;
  repeat ShowTimers until Get406C>$180000 ;
  while N>0 do begin Str(N, S6) ;
    WrScr(LastScroll+3, ' The following will repeat '+S6+' times', Co1) ;
    WrScr(LastScroll+4, ' Wait until midnight shown below', Co1) ;
    for K := 5 to Pred(FixedRows) do WrScr(LastScroll+K, '', Co1) ;
    repeat ShowTimers until Get406C<200 ;
    WrScr(LastScroll+5, ' Wait until Ticks=200 ', Co1) ;
    repeat ShowTimers until Get406C>200 ;
    Put406C($180000) ;
    WrScr(LastScroll+6,
      ' Program has set MSDOS timer $40:$6C to $180000 ~= 23:59:50 ;', Co1) ;
    PutRTCTimeDirectly(BCD(23), BCD(59), BCD(50)) ;
    WrScr(LastScroll+7, ' Program has direct-set RTC time to 23:59:50', Co1) ;
    WrScr(LastScroll+8, ' ... Wait', Co1) ;
    repeat ShowTimers until Get406C=100 ;
    Dec(N) end ;
  repeat ShowTimers until Get406C<$100000 ;
  WrScr(LastScroll+9, ' Press enter key for prompt (Date? Time?) ', Co1) ;
  repeat ShowTimers until KeyPushed ;
  end {ART} ;

const
Cstr03 = 'Accelerated Rollover Test - 1999->2000 - N clear days delay' ;
Str03 : string [Length(Cstr03)] = Cstr03 ;
Job03 : OpT = (Last:@Job02; PGen:@Str03; Task:Art; Comm:'ART') ;

procedure ReadClockBuck(var Cmnd : S80) ; FAR ;
var S7 : string [7] ; Buff : TBuf ;
begin ReadClockDollar(Buff) ;
  with Buff do begin Str(DayCount:7, S7) ;
    Show(Was+S7+' days, time '+CC(Hours)+':'+CC(Minutes)+':'+
      CC(Seconds)+'.'+CC(CentiSecs)) end ;
  end {ReadClockBuck} ;

const
Cstr04 = 'Read the DOS CLOCK$ device' ;
Str04 : string [Length(Cstr04)] = Cstr04 ;
Job04 : OpT = (Last:@Job03; PGen:@Str04; Task:ReadClockBuck; Comm:'READCLOCK$') ;

procedure WriteClockBuck(var Cmnd : S80) ; FAR ;
var S7 : string [7] ; Buff : TBuf ;
begin with Buff do begin DayCount := GetL(Cmnd) ;
    Hours := GetL(Cmnd) ; Minutes := GetL(Cmnd) ; Seconds := GetL(Cmnd) ;
    CentiSecs := 0 ;
    WriteClockDollar(Buff) ;
    ReadClockDollar(Buff) ;
    Str(DayCount:7, S7) ;
    Show(Was+'   Now:'+S7+' days, time '+CC(Hours)+':'+CC(Minutes)+':'+
      CC(Seconds)+'.'+CC(CentiSecs)) ;
    end end {WriteClockBuck} ;

const
Cstr05 = 'Write the DOS CLOCK$ device' ;
Str05 : string [Length(Cstr05)] = Cstr05 ;
Job05 : OpT = (Last:@Job04; PGen:@Str05; Task:WriteClockBuck; Comm:'WRITECLOCK$') ;

procedure SeeCLOCKbuf(var Cmnd : S80) { ONLY reads a buffer } ; FAR ;
var Sa, Sb, Sc : string [5] ;
begin with ClockRecPtr^ do begin { Swap-state of ClockRecPtr^ uncertain }
    Str(BufRY+1980:5, Sa) ; Str(BufDC, Sb) ; Str(BufDW, Sc) ;
    Show(Was+' MSDOS buffer ' + Sa+Sp+CC(BufM)+Sp+CC(BufD) +
      Sp+Sc+' ('+Weekdays[BufDW]+'), Day '+Sb) ;
    end end {SeeCLOCKbuf} ;

const
Cstr06 = 'Read the current MSDOS CLOCK$ buffer' ;
Str06 : string [Length(Cstr06)] = Cstr06 ;
Job06 : OpT = (Last:@Job05; PGen:@Str06; Task:SeeClockBuf; Comm:'SEECLOCK$BUF') ;

procedure PutCLOCKbuf(var C : S80) { ONLY writes a buffer } ; FAR ;
begin with ClockRecPtr^ do begin { Swap-state of ClockRecPtr^ uncertain }
    BufRY := GetL(C)-1980 ; BufM := GetL(C) ; BufD := GetL(C) ;
    BufDW := GetL(C) ; BufDC := GetL(C) ; SeeCLOCKbuf(C) ;
    end end {PutCCLOCKbuf} ;

const
Cstr07 = 'Write the current MSDOS CLOCK$ buffer (futile)' ;
Str07 : string [Length(Cstr07)] = Cstr07 ;
Job07 : OpT = (Last:@Job06; PGen:@Str07; Task:PutClockBuf; Comm:'PUTCLOCK$BUF') ;

procedure CMOSview(var Cmnd : S80) ; FAR ;
var J : RTCaddr ; K : byte ; S : S80 ;
CMOS : array [RTCaddr] of byte ;
begin Show('Wait') ;
  WaitForUIPendCLI ;
  for J := RTCbot to RTCtop do begin
    Port[$70] := J ; CMOS[J] := Port[$71] end ;
  STI ;
  ShowUp(' Sc SA Mn MA  Hr HA DW Dy  Mo YY  A  B   C  D <- RTC') ;
  S := '' ;
  for J := RTCbot to RTCtop do begin
    if J>RTCbot then
      if J mod 16 = 0 then begin ShowUp(S) ; S := '' end else
      if J mod 4 = 0 then S := S + Sp ;
    K := CMOS[J] ;
    S := S + Sp + Hex2(K) ;
    end ;
  ShowUp(S) ; S := ' As text '#17 ;
  for J := RTCbot to RTCtop do begin
    if CMOS[J] in [32..254]
      then S := S + char(CMOS[J]) else S := S + #22 ;
    if J = 63 then begin ShowUp(S+#16) ; S := '         '#17 end ;
    end ;
  ShowUp(S+#16) ;
  Show('CMOSVIEW :') end {CMOSview} ;

const
Cstr08 = 'Read 128 bytes of CMOS RAM after RTC 1s update' ;
Str08 : string [Length(Cstr08)] = Cstr08 ;
Job08 : OpT = (Last:@Job07; PGen:@Str08; Task:CMOSview; Comm:'CMOSVIEW') ;

procedure PutRTCcy(var Cmnd : S80) ; FAR ;
var RTC : RTCrec ;
begin with RTC do begin rCy := BCD(GetL(Cmnd)) ;
    Show(Was+NN(rCy)) ; PutRTCcyDirectly(rCy) end end {PutRTCcy} ;

const
Cstr09 = 'Write to the RTC century byte' ;
Str09 : string [Length(Cstr09)] = Cstr09 ;
Job09 : OpT = (Last:@Job08; PGen:@Str09; Task:PutRTCcy; Comm:'PUTRTCCY') ;

procedure HardBoot(var Cmnd : S80) ; FAR ;
begin ShowCmnd(Was+'Are you really sure?', Co2) ;
  if UpCase(char(Lo(GetKbd)))='Y' then Boots['A'].BootProc ;
  end {HardBoot} ;

const
Cstr10 = 'Use DOS keyboard driver to pulse CPU reset pin (OK on most PCs?)' ;
Str10 : string [Length(Cstr10)] = Cstr10 ;
Job10 : OpT = (Last:@Job09; PGen:@Str10; Task:HardBoot; Comm:'REBOOT') ;

procedure SetCMOSreg(var Cmnd : S80) ; FAR ;
var RTC : RTCrec ; J, K : byte ;
begin with RTC do begin
    J := GetL(Cmnd) ; K := GetL(Cmnd) ;
    Show(Was+'$'+Hex2(J)+':= $'+Hex2(K)) ;
    UnIntPutCMOSreg(K, J) end end {SetCMOSreg} ;

const
Cstr11 = 'Write to RTC register $NN value $XX' ;
Str11 : string [Length(Cstr11)] = Cstr11 ;
Job11 : OpT = (Last:@Job10; PGen:@Str11; Task:SetCMOSreg; Comm:'SETCMOSREG') ;

procedure SetRTC(var Cmnd : S80) ; FAR ;
var RTC : RTCrec ; J : word ;
begin with RTC do begin
    J := GetL(Cmnd) ; rYr := BCD(J mod 100) ; rCy := BCD(J div 100) ;
    rMo := BGet(Cmnd) ; rDy := BGet(Cmnd) ;
    rHr := BGet(Cmnd) ; rMi := BGet(Cmnd) ; rSc := BGet(Cmnd) ;
    Show(Was+DateTimeStringRTC(RTC)) ;
    PutRTCdirectly(RTC) end end {SetRTC} ;

const
Cstr12 = 'Directly write the date & time to the RTC' ;
Str12 : string [Length(Cstr12)] = Cstr12 ;
Job12 : OpT = (Last:@Job11; PGen:@Str12; Task:SetRTC; Comm:'SETRTC') ;

procedure GetRTC(var Cmnd : S80) ; FAR ;
var RTC : RTCrec ;
begin GetRTCdirectly(RTC) ; Show(Was+DateTimeStringRTC(RTC)) end {GetRTC} ;

const
Cstr13 = 'Directly read the date & time in the RTC' ;
Str13 : string [Length(Cstr13)] = Cstr13 ;
Job13 : OpT = (Last:@Job12; PGen:@Str13; Task:GetRTC; Comm:'GETRTC') ;

procedure RRRTC(var Cmnd : S80) ; FAR ;
type RTCrdgs = record U0, S1, Mi, Hr, S4, U5 : byte end ;
DataLine = record Rdgs : RTCrdgs ; Count : longint ;
  CTC : record case byte of
    0 : (TimeStamp : longint) ;
    1 : (LoWd, HiWd : word) ;
    2 : (LoBy, HiBy : byte) end end ;
var P : array [0..55000 div SizeOf(DataLine)] of DataLine ;
LocalMax : word ;

const wider = false
  { Retain the possibility of readily reading more RTC registers } ;


procedure CollectData { Vlado, now tested, seems an improvement } ;
var J : word ;
const Size = SizeOf(RTCrdgs) ;
const RSize = SizeOf(DataLine) ;
begin
  J := GetL(Cmnd) ;
  if (J>0) and (J<=High(P)) then LocalMax := J else
    if (GlobalMax>0) and (GlobalMax<=High(P)) then LocalMax := GlobalMax
    else LocalMax := DefaultMax ;
  WaitForUIPend ; Show(' Wait a few seconds') ;
  WrScr(LastScreenRow, '', Co5) ;
  FillChar(P[0], SizeOf(P[0]), 0) ;

  asm
      mov si,ss:[bp+4] { si -> RRRTC stack frame }
      push ds ; push bp { save to use within loop }

      { Reprogram CTC timer #2 for single byte load/store }
      in al,61h { get PPI value }
      and al,0fch { disconnect speaker from timer 2 }
      or al,1 { enable timer 2 }
      out 61h,al { write back into PPI }
      mov al,94h ; out 43h,al { set read/load LSB mode for timer 2 }
      xor al,al ; out 42h,al { reset timer 2 }

      { Initialize some variables }
      push ss ; pop es { es = ss }
      push ss ; pop ds { ds = ss }
      mov ax,es:[si+offset LocalMax] ; inc ax { ax = for... counter }
      add si,offset P { es:si -> the start of the P[0..] array }

      { bx is LoWord, dx is HiWord of the SampleNumber }
      xor bx,bx ; xor dx,dx { reset SampleNumber }

      { cx is LoWord, bp is HiWord of the software timer }
      xor cx,cx ; xor bp,bp { reset SW timer }
      cld ;

    { for J := 1 to LocalMax do begin }
    @@forloop:
      push ax { save for... counter }

      { repeat read RTC until it changes } ;
    @@rptloop:
      sti ; cli { enough to service pending interrupts }
      inc bx ; jnz @1 ; inc dx ; { inc SampleNumber }
    @1: mov di,si { es:di -> old RTC readings }

      { software timer housekeeping }
      in al,42H { get timer 2 value }
      xchg al,cl { al = old, cl = new }
      cmp al,cl { on overflow (i.e. old < new) carry is set }
      sbb ch,0 ; sbb bp,0 { if overflow dec high 24 bits of the SW timer }

      { Read the RTC. If some value has changed replace it by the new one }
      { Note that in/out/mov/xchg/stosw instructions do not affect the Z flag }
      mov al,0ah ; out 70h,al ; in al,71h ; mov ah,al { get U0 }
      mov al,00h ; out 70h,al ; in al,71h ; xchg ah,al { get S1 }
      scasw { change in U0,S1? } ; je @2 { e - no }
      mov es:[di-2],ax { store the new U0,S1 } ;
    @2: mov al,02h ; out 70h,al ; in al,71h ; mov ah,al { get Mi }
      mov al,04h ; out 70h,al ; in al,71h ; xchg ah,al { get Hr }
      jne @3 { ne - change in previous items }
      scasw { change in Mi,Hr? } ; je @4 { e - no }
      lea di,-2[di] { di = di-2, Z flag not affected } ;
    @3: stosw { store the new Mi,Hr } ;
    @4: mov al,00h ; out 70h,al ; in al,71h ; mov ah,al { get S4 }
      mov al,0ah ; out 70h,al ; in al,71h ; xchg ah,al { get U5 }
      jne @5 { ne - change in previous items }
      scasw { change in S4,U5? } ; je @@rptloop { e - no }
      lea di,-2[di] { di = di-2, Z flag not affected } ;
    @5: stosw { store the new S4,U5 }

      { Complete the record by the SampleNumber and the software timer }
      mov ax,bx ; stosw ; mov ax,dx ; stosw { the SampleNumber }
      mov ax,cx ; stosw ; mov ax,bp ; stosw { the timer }

      { Prepare a new record
      - copy in advance the 6 RTC values from the old record }
      push di { di -> start of the new record }
      movsw ; movsw ; movsw
      pop si { si -> start of the new record }

      pop ax { ax = the for... counter }
      dec ax ; jnz @@forloop
      sti

      { Reprogram CTC channel #2 for double byte load/store }

      mov al,0b4h ; out 43h,al { set double byte mode for timer 2 }

      pop bp ; pop ds { recover them }
      end { of inline assembler section } ;
  end {CollectData} ;

procedure GatherData ;
var NewDataPtr, OldDataPtr : ^DataLine ;
SampleNumber : longint ; Timer, XW, J : word ; B : boolean ;
const Size = SizeOf(RTCrdgs) ;
begin WaitForUIPend ;
  J := GetL(Cmnd) ;
  if (J>0) and (J<=High(P)) then LocalMax := J else
    if (GlobalMax>0) and (GlobalMax<=High(P)) then LocalMax := GlobalMax
    else LocalMax := DefaultMax ;
  Show(' Wait a few seconds') ;
  WrScr(LastScreenRow, '', Co5) ;
  OldDataPtr := Addr(P[0]) ;
  FillChar(P[0], SizeOf(P[0]), 0) ; SampleNumber := 0 ;
  Timer := $FFFF ; XW := $FFFF ;

  for J := 1 to LocalMax do begin NewDataPtr := Addr(P[J]) ;
    with NewDataPtr^, Rdgs, CTC do

      if wider then begin

      repeat Inc(SampleNumber) ; Count := SampleNumber ;
        DI { no interrupts while reading RTC and CTC } ;
        Port[$70] := $0A ; U0 := Port[$71] ;
        Port[$70] := $00 ; S1 := Port[$71] ;
        Port[$70] := $02 ; Mi := Port[$71] ;
        Port[$70] := $04 ; Hr := Port[$71] ;
        Port[$70] := $00 ; S4 := Port[$71] ;
        Port[$70] := $0A ; U5 := Port[$71] ;

        Port[$43] := 0 { Latch Ch. 0 - s.7.15 } ;
        { CTC $40,40 double-decrements at 1.19 MHz - PCTIM003 s.7.16 }
        LoBy := Port[$40] ; HiBy := Port[$40] ;
        EI ;
        if LoWd > XW then Dec(Timer) ;
        HiWd := Timer ; XW := LoWd ;

        { B := CompareMemory(P[J].Rdgs.U0, P[J-1].Rdgs.U0, SizeOf(Rdgs))>0 ; }
        asm { Pedt }  mov dx,ds ; xor ax,ax
            mov cx,Size ; lds si,[NewDataPtr] ; les di,[OldDataPtr]
            cld ; repe cmpsb
            je @@out ; inc ax ;
          @@out:  mov ds,dx ; mov [B],al  end ;
        until B ;

      end {wider} else {not wider} begin { Vlado }

      { repeat Inc(SampleNumber) ; Count := SampleNumber ; }
      asm
          push es ; push di  {save to use within the repeat loop}
          mov si,XW          {get in si for faster access}
          cld ;



        @@rptloop:
          inc word ptr SampleNumber ; jnz @1
          inc word ptr SampleNumber+2 ;
        @1:

          { DI { no interrupts while reading RTC and CTC   ;}
          { Port[$70] := $0A ; U0 := Port[$71] ;            }
          { Port[$70] := $00 ; S1 := Port[$71] ;            }
          { Port[$70] := $02 ; Mi := Port[$71] ;            }
          { Port[$70] := $04 ; Hr := Port[$71] ;            }
          { Port[$70] := $00 ; S4 := Port[$71] ;            }
          { Port[$70] := $0A ; U5 := Port[$71] ; }

          cli

          { The actual storing of RTC values in the memory is postponed
          until the new reading differs from the previous one }

          mov al,0ah ; out 70h,al ; in al,71h ; mov bl,al {remember U0}
          mov al,00h ; out 70h,al ; in al,71h ; mov bh,al {remember S1}
          mov al,02h ; out 70h,al ; in al,71h ; mov cl,al {remember Mi}
          mov al,04h ; out 70h,al ; in al,71h ; mov ch,al {remember Hr}
          mov al,00h ; out 70h,al ; in al,71h ; mov dl,al {remember S4}
          mov al,0ah ; out 70h,al ; in al,71h ; mov dh,al {remember U5}

          { Port[$43] := 0 { Latch Ch. 0 - s.7.15 }
          { { CTC $40,40 double-decrements at 1.19 MHz - PCTIM003 s.7.16 }
          { LoBy := Port[$40] ; HiBy := Port[$40] ; }
          { EI ;}

          xor al,al ; out 43h,al      {Latch CTC for stable read}
          in al,40h ; mov ah,al       {read lo part}
          in al,40h ; xchg ah,al      {read hi part, ax = 16bit CTC value}
          sti

          { if LoWd > XW then Dec(Timer) ;
          HiWd := Timer ; XW := LoWd ; }

          xchg ax,si                   {XW = LoWd, ax = old XW}
          cmp  ax,si ; sbb Timer,0     {if CTC overflows dec Timer}

          { B := CompareMemory(P[J].Rdgs.U0, P[J-1].Rdgs.U0, SizeOf(Rdgs))>0 ; }

          les di,[OldDataPtr]
          mov ax,bx ; scasw ; jne @@out {old readings = new readings? ne - no}
          mov ax,cx ; scasw ; jne @@out {old readings = new readings? ne - no}
          mov ax,dx ; scasw             {old readings = new readings? ne - no}
          je  @@rptloop                 {keep reading until data changes} ;



        @@out:  mov XW,si               {remember XW}
          les di,[NewDataPtr]
          mov ax,bx ; stosw ; mov ax,cx ; stosw ; mov ax,dx ; stosw
          mov ax,word ptr SampleNumber ; stosw      {store Count low part}
          mov ax,word ptr SampleNumber+2 ; stosw    {store Count hi part}
          mov ax,si ; stosw            {LoWd}
          mov ax,Timer ; stosw         {HiWd}
          pop di ; pop es              {pop outside the repeat loop}
          end ;                        {end of inline assembler section}

      end {not wider} ;

    OldDataPtr := NewDataPtr ;
    end {J} ;
  end {GatherData} ;

procedure WriteFile ;
const FN = 'int_test.out' ; Hz = 1193182 ; dHz = 119318 ;
var F : text ; DT, XT : longint ; J, W : word ; E : EpochRec ;
begin
  Show(' Writing File '+FN) ;
  Assign(F, FN) ; ReWrite(F) ;
  with DosVer do
    Writeln(F, ' From ', ID, ^M^J^M^J' DOS: ', Maj, '.', Min) ;
  with E do begin
    GetDate(eYr, eMo, eDy, J) ; GetTime(eHr, eMi, eSc, J) end ;
  Writeln(F, DateTimeStringDOS(E)) ;
  Writeln(F, ' VladoProc ', VladoProc) ;

  W := 0 ; { Any time even => mode 2, else assume Mode 3 }
  for J := 1 to LocalMax do with P[J].CTC do W := W or LoWd ;
  W := 2-Ord(Odd(W)) ;
  Writeln(F, ' CTC seems to be in Mode ', Succ(W), ' so divide by ', W) ;

  Writeln(F, ^M^J, '':7,
    'Total Time   ----- Time -----   Sample    ---- RTC registers ----',
    ^M^J, '':7,
    '* 0.8381us      Difference      Number    RegA Secs Hr:Mn:Sc RegA') ;

  XT := 0 ;
  for J := 1 to LocalMax do with P[J], Rdgs, CTC do begin
    TimeStamp := (-TimeStamp) div W ; Write(F, J:5, TimeStamp:12)  ;
    { "div 2" assumes CTC mode 3 ; "div 1" assumes CTC mode 2 }
    if J=1 then Write(F, '':19) else begin
      DT := TimeStamp-XT ; Write(F, DT:10) ;
      if DT<21000 then Write(F, ((DT*100000 + (dHz div 2)) div dHz):7, 'us')
        else Write(F, ((DT*1000 + (Hz div 2)) div Hz):6, 'ms ') ;
      end ;

    Writeln(F, Count:9, '..   ',
      NN(U0), '':3, NN(S1), '':2, NN(Hr), ':',
      NN(Mi), ':', NN(S4), '':2, NN(U5)) ;
    XT := TimeStamp end ;

  Writeln(F, ^M^J,
    '  Other samples match the previous one shown.'^M^J,
    '  Note: Time resolution is not real; be guided by the Sample Number.') ;
  Close(F) ;
  Show(' File '+FN+' written.') ;
  end {WriteFile} ;

begin GoXY(0, CmdLine) ;
  if VladoProc then CollectData else GatherData ;
  WriteFile end {RRRTC} ;

const
Cstr14 = 'Rapid-read RTC and report changes; [N = report count]' ;
Str14 : string [Length(Cstr14)] = Cstr14 ;
Job14 : OpT = (Last:@Job13; PGen:@Str14; Task:RRRTC; Comm:'RRRTC') ;

procedure TimedRTC(var Cmnd : S80) ; FAR ;
var RTC : RTCrec ; Epo : EpochRec ;
begin GetRTCDirectly(RTC) ;
  with RTC, Epo do begin
    rHr := BGet(Cmnd) ; rMi := BGet(Cmnd) ; rSc := BGet(Cmnd) ;
    PutRTCdirectly(RTC) ; RRRTC(Cmnd) ;
    GetTime(eHr, eMi, eSc, eCs) ; SetTime(eHr, eMi, eSc, eCs) ;
    end end {TimedRTC} ;

const
Cstr15 = 'Set RTC [H M S]; Rapid-read RTC [N]; Correct RTC' ;
Str15 : string [Length(Cstr15)] = Cstr15 ;
Job15 : OpT = (Last:@Job14; PGen:@Str15; Task:TimedRTC; Comm:'TIMEDRTC') ;

procedure InitRTC(var Cmnd : S80) { DUBIOUS } ; FAR ;
const A : array [0..9] of byte = (0,0,0,0,0,0, 0, 1, 1, $99) ;
var K : byte ;
begin
  WrScr(LastScroll, ' ** INITRTC is both dangerous and incomplete ** ', Co3) ;
  (* WaitForUIPend ;
    PutCMOSreg($82, $0B) ;
    for K := Low(A) to High(A) do PutCMOSreg(A[K], K) ;
    PutRTCcyDirectly($20) ;
    PutCMOSreg($02, CCinCMOS) ;
    { PutRTCcyDirectly($19) ;}
    *)
  Scroll ;
  WrScr(LastScroll, ' ** and so is inactivated, bar these 2 lines ** ', Co3) ;
  end {InitRTC} ;

const
Cstr16 = 'Fatally initialise the RTC' ;
Str16 : string [Length(Cstr16)] = Cstr16 ;
Job16 : OpT = (Last:@Job15; PGen:@Str16; Task:InitRTC; Comm:'INITRTC') ;

procedure SetCCloc(var Cmnd : S80) ; FAR ;
begin CCinCMOS := GetL(Cmnd) ;
  Show(Was+ '$' + Hex2(CCinCMOS)) end {SetCCloc} ;

const
Cstr17 = 'Set the address of the RTC century byte' ;
Str17 : string [Length(Cstr17)] = Cstr17 ;
Job17 : OpT = (Last:@Job16; PGen:@Str17; Task:SetCCloc; Comm:'SETCCLOC') ;

procedure BPGetDate(var Cmnd : S80) ; FAR ;
var Epo : EpochRec ;
begin with Epo do begin
    GetDate(eYr, eMo, eDy, eDoW) ;
    Show(Was+DateStringDOS(Epo) + Sp + Weekdays[eDoW]) end end {BPGetDate} ;

const
Cstr18 = 'Call BP Sys.GetDate' ;
Str18 : string [Length(Cstr18)] = Cstr18 ;
Job18 : OpT = (Last:@Job17; PGen:@Str18; Task:BPGetDate; Comm:'GETDATE') ;

procedure BPSetDate(var Cmnd : S80) ; FAR ;
var Epo : EpochRec ;
begin with Epo do begin
    eYr := GetL(Cmnd) ; eMo := GetL(Cmnd) ; eDy := GetL(Cmnd) ;
    Show(Was+DateStringDOS(Epo)) ; SetDate(eYr, eMo, eDy) ;
    end end {BPSetDate} ;

const
Cstr19 = 'Call BP Sys.SetDate' ;
Str19 : string [Length(Cstr19)] = Cstr19 ;
Job19 : OpT = (Last:@Job18; PGen:@Str19; Task:BPSetDate; Comm:'SETDATE') ;

procedure BPGetTime(var Cmnd : S80) ; FAR ;
var Epo : EpochRec ;
begin with Epo do begin
    GetTime(eHr, eMi, eSc, eCs) ;
    Show(Was+TimeStringDOS(Epo)) end end {BPGetTime} ;

const
Cstr20 = 'Call BP Sys.GetTime' ;
Str20 : string [Length(Cstr20)] = Cstr20 ;
Job20 : OpT = (Last:@Job19; PGen:@Str20; Task:BPGetTime; Comm:'GETTIME') ;

procedure BPSetTime(var Cmnd : S80) ; FAR ;
var Epo : EpochRec ;
begin with Epo do begin
    eHr := GetL(Cmnd) ; eMi := GetL(Cmnd) ; eSc := GetL(Cmnd) ; eCs := 0 ;
    Show(Was+TimeStringDOS(Epo)) ; SetTime(eHr, eMi, eSc, eCs) ;
    end end {BPSetTime} ;

const
Cstr21 = 'Call BP Sys.SetTime' ;
Str21 : string [Length(Cstr21)] = Cstr21 ;
Job21 : OpT = (Last:@Job20; PGen:@Str21; Task:BPSetTime; Comm:'SETTIME') ;

procedure PS2RDC(var Cmnd : S80) ; FAR ;
var Regs : Registers ; S7 : string [7] ;
begin with Regs do begin
    AH := $0A ; CX := 0 ; Intr($1A, Regs) ;
    if (Flags and FCarry)<>0 then UpShow(Was+'Error!') else
      begin Str(CX, S7) ; Show(Was+Sp+S7+' daycount') end ;
    end end {PS2RDC} ;

const
Cstr22 = 'PS/2 Read Daycount ?' ;
Str22 : string [Length(Cstr22)] = Cstr22 ;
Job22 : OpT = (Last:@Job21; PGen:@Str22; Task:PS2RDC; Comm:'PS2RDC') ;

procedure PS2WDC(var Cmnd : S80) ; FAR ;
var Regs : Registers ; S7 : string [7] ;
begin with Regs do begin
    AH := $0B ; CX := GetL(Cmnd) ; Intr($1A, Regs) ;
    if (Flags and FCarry)<>0 then UpShow(Was+'Error!') else
      begin Str(CX, S7) ; Show(Was+Sp+S7+' daycount') end ;
    end end {PS2WDC} ;

const
Cstr23 = 'PS/2 Write Daycount ?' ;
Str23 : string [Length(Cstr23)] = Cstr23 ;
Job23 : OpT = (Last:@Job22; PGen:@Str23; Task:PS2WDC; Comm:'PS2WDC') ;

procedure Int21_2A(var Cmnd : S80) ; FAR ;
var Regs : Registers ; Epo : EpochRec ;
begin with Epo, Regs do begin
    AH := $2A ; MsDos(Regs) ;
    eYr := CX ; eMo := DH ; eDy := DL ; eDoW := AL ;
    Show(Was + DateStringDOS(Epo) + Sp + Weekdays[eDoW]) ;
    end end {Int21_2A} ;

const
Cstr24 = 'Call DOS Int 21/2A' ;
Str24 : string [Length(Cstr24)] = Cstr24 ;
Job24 : OpT = (Last:@Job23; PGen:@Str24; Task:Int21_2A; Comm:'21/2A') ;

procedure Int21_2B(var Cmnd : S80) ; FAR ;
var Regs : Registers ; Epo : EpochRec ;
begin with Epo, Regs do begin
    eYr := GetL(Cmnd) ; eMo := GetL(Cmnd) ; eDy := GetL(Cmnd) ;
    Show(Was+DateStringDOS(Epo)) ;
    AH := $2B ; CX := eYr ; DH := eMo ; DL := eDy ; MsDos(Regs) ;
    if AL<>0 then UpShow(Was+'Invalid!') ;
    end end {Int21_2B} ;

const
Cstr25 = 'Call DOS Int 21/2B' ;
Str25 : string [Length(Cstr25)] = Cstr25 ;
Job25 : OpT = (Last:@Job24; PGen:@Str25; Task:Int21_2B; Comm:'21/2B') ;

procedure Int21_2C(var Cmnd : S80) ; FAR ;
var Regs : Registers ; Epo : EpochRec ;
begin with Epo, Regs do begin
    AH := $2C ; MsDos(Regs) ;
    eHr := CH ; eMi := CL ; eSc := DH ;
    Show(Was+TimeStringDOS(Epo)) end end {Int21_2C} ;

const
Cstr26 = 'Call DOS Int 21/2C' ;
Str26 : string [Length(Cstr26)] = Cstr26 ;
Job26 : OpT = (Last:@Job25; PGen:@Str26; Task:Int21_2C; Comm:'21/2C') ;

procedure Int21_2D(var Cmnd : S80) ; FAR ;
var Regs : Registers ; Epo : EpochRec ;
begin with Epo, Regs do begin
    eHr := GetL(Cmnd) ; eMi := GetL(Cmnd) ; eSc := GetL(Cmnd) ; eCs := 0 ;
    Show(Was+TimeStringDOS(Epo)) ;
    AH := $2D ; CH := eHr ; CL := eMi ; DH := eSc ; DL := eCs ;
    MsDos(Regs) ;
    if AL<>0 then UpShow(Was+'Invalid!') ;
    end end {Int21_2D} ;

const
Cstr27 = 'Call DOS Int 21/2D' ;
Str27 : string [Length(Cstr27)] = Cstr27 ;
Job27 : OpT = (Last:@Job26; PGen:@Str27; Task:Int21_2D; Comm:'21/2D') ;

procedure Int1A_04(var Cmnd : S80) ; FAR ;
var Regs : Registers ; Epo : EpochRec ;
begin with Epo, Regs do begin
    AH := $04 ; Intr($1A, Regs) ;
    if (Flags and FCarry)<>0 then UpShow(Was+'No RTC!') else
      begin eYr := DCB(CH)*100+DCB(CL) ; eMo := DCB(DH) ; eDy := DCB(DL) ;
      Show(Was+DateStringDOS(Epo)) end ;
    end end {Int1A_04} ;

const
Cstr28 = 'Call BIOS Int 1A/04' ;
Str28 : string [Length(Cstr28)] = Cstr28 ;
Job28 : OpT = (Last:@Job27; PGen:@Str28; Task:Int1A_04; Comm:'1A/04') ;

procedure Int1A_05(var Cmnd : S80) ; FAR ;
var Regs : Registers ; Epo : EpochRec ;
begin with Epo, Regs do begin
    eYr := GetL(Cmnd) ; eMo := GetL(Cmnd) ; eDy := GetL(Cmnd) ;
    Show(Was+DateStringDOS(Epo)) ;
    AH := $05 ; CH := BCD(eYr div 100) ; CL := BCD(eYr mod 100) ;
    DH := BCD(eMo) ; DL := BCD(eDy) ; Intr($1A, Regs) ;
    end end {Int1A_05} ;

const
Cstr29 = 'Call BIOS Int 1A/05' ;
Str29 : string [Length(Cstr29)] = Cstr29 ;
Job29 : OpT = (Last:@Job28; PGen:@Str29; Task:Int1A_05; Comm:'1A/05') ;

procedure Int1A_02(var Cmnd : S80) ; FAR ;
const DSTon : array [boolean] of string [3] = ('OFF', ' ON') ;
var Regs : Registers ; Epo : EpochRec ;
begin with Epo, Regs do begin
    AH := $02 ; Intr($1A, Regs) ;
    if (Flags and FCarry)<>0 then UpShow(Was+'No RTC!') else
      begin eHr := DCB(CH) ; eMi := DCB(CL) ; eSc := DCB(DH) ;
      Show(Was+TimeStringDOS(Epo)+' DST:'+DSTon[DL<>0]) end ;
    end end {Int1A_02} ;

const
Cstr30 = 'Call BIOS Int 1A/02' ;
Str30 : string [Length(Cstr30)] = Cstr30 ;
Job30 : OpT = (Last:@Job29; PGen:@Str30; Task:Int1A_02; Comm:'1A/02') ;

procedure Int1A_03(var Cmnd : S80) ; FAR ;
var Regs : Registers ; Epo : EpochRec ;
begin with Epo, Regs do begin
    eHr := GetL(Cmnd) ; eMi := GetL(Cmnd) ; eSc := GetL(Cmnd) ;
    Show(Was+TimeStringDOS(Epo)) ;
    AH := $03 ; CH := BCD(eHr) ;
    CL := BCD(eMi) ; DH := BCD(eSc) ; DL := 0 ; Intr($1A, Regs) ;
    end end {Int1A_03} ;

const
Cstr31 = 'Call BIOS Int 1A/03' ;
Str31 : string [Length(Cstr31)] = Cstr31 ;
Job31 : OpT = (Last:@Job30; PGen:@Str31; Task:Int1A_03; Comm:'1A/03') ;

procedure Int1A_00(var Cmnd : S80) ; FAR ;
var Regs : Registers ; LI : longint ;
S10 : string [10] ; S3 : string [3] ;
begin with Regs do begin
    AH := $00 ; Intr($1A, Regs) ;
    LI := (longint(CX) shl 16) + DX ;
    Str(LI:10, S10) ; Str(AL, S3) ; Show(Was+S10+Sp+S3+'d') ;
    end end {Int1A_00} ;

const
Cstr32 = 'Call BIOS Int 1A/00' ;
Str32 : string [Length(Cstr32)] = Cstr32 ;
Job32 : OpT = (Last:@Job31; PGen:@Str32; Task:Int1A_00; Comm:'1A/00') ;

procedure Int1A_01(var Cmnd : S80) ; FAR ;
var Regs : Registers ; LI : longint ; S10 : string [10] ;
begin with Regs do begin
    LI := GetL(Cmnd) ; Str(LI:10, S10) ; Show(Was+S10) ;
    AH := $01 ; CX := LI shr 16 ; DX := LI and $FFFF ; Intr($1A, Regs) ;
    end end {Int1A_01} ;

const
Cstr33 = 'Call BIOS Int 1A/01' ;
Str33 : string [Length(Cstr33)] = Cstr33 ;
Job33 : OpT = (Last:@Job32; PGen:@Str33; Task:Int1A_01; Comm:'1A/01') ;

procedure FGet406C(var Cmnd : S80) ; FAR ;
var T : longint ; D : byte ; S3 : string [3] ; S12 : string [12] ;
begin DI ; T := MemL[Seg0040:$006C] ; D := Mem[Seg0040:$0070] ; EI ;
  Str(T:12, S12) ; Str(D:2, S3) ; Show(Was+S12+S3+'d') end {FGet406C} ;

const
Cstr34 = 'Directly read DOS 18.2Hz timer' ;
Str34 : string [Length(Cstr34)] = Cstr34 ;
Job34 : OpT = (Last:@Job33; PGen:@Str34; Task:FGet406C; Comm:'GET406C') ;

procedure FSet406C(var Cmnd : S80) ; FAR ;
var S12 : string [12] ; LI : longint ;
begin LI := GetL(Cmnd) ; Str(LI:12, S12) ; Show(Was+S12) ;
  if LI<$400000 then Put406C(LI) else UpShow('        Too big') ;
  end {FSet406C} ;

const
Cstr35 = 'Directly write to the DOS 18.2Hz timer' ;
Str35 : string [Length(Cstr35)] = Cstr35 ;
Job35 : OpT = (Last:@Job34; PGen:@Str35; Task:FSet406C; Comm:'SET406C') ;

procedure FExec(var Cmnd : S80) ; FAR ;
begin
  Swapvectors ;
  Exec(GetEnv('COMSPEC'), ' /C cls') ;
  Exec(GetEnv('COMSPEC'), ' /C '+Cmnd) ;
  Swapvectors ; Write('Press space bar:') ; WaitKbd ; Show(Was) ;
  end {FExec} ;

const
Cstr36 = 'Execute in DOS shell' ;
Str36 : string [Length(Cstr36)] = Cstr36 ;
Job36 : OpT = (Last:@Job35; PGen:@Str36; Task:FExec; Comm:'EXEC') ;

const
Cstr37 = 'Seek undocumented DOS DayCount location by underhand means' ;
Str37 : string [Length(Cstr37)] = Cstr37 ;
Job37 : OpT = (Last:@Job36; PGen:@Str37; Task:FindDayCount; Comm:'FINDDAYCOUNT') ;

procedure HexSetRTC(var Cmnd : S80) ; FAR ;
var RTC : RTCrec ; J : word ;
begin with RTC do begin
    J := GetL(Cmnd) ; rYr := J mod $100 ; rCy := J div $100 ; {??}
    rMo := GetL(Cmnd) ; rDy := GetL(Cmnd) ;
    rHr := GetL(Cmnd) ; rMi := GetL(Cmnd) ; rSc := GetL(Cmnd) ;
    Show(Was+DateTimeStringRTC(RTC)) ;
    PutRTCdirectly(RTC) end end {HexSetRTC} ;

const
Cstr38 = 'Directly write the HEX date & time to the RTC' ;
Str38 : string [Length(Cstr38)] = Cstr38 ;
Job38 : OpT = (Last:@Job37; PGen:@Str38; Task:HexSetRTC; Comm:'HEXSETRTC') ;

procedure LeapRTC(var Cmnd : S80) ; FAR ;
const Feb : array [28..29] of RTCrec =
  ( (rCy:0; rYr:0; rMo:$02; rDy:$28; rHr:$23; rMi:$59; rSc:$56),
  (  rCy:0; rYr:0; rMo:$02; rDy:$29; rHr:$23; rMi:$59; rSc:$55) ) ;
Ans : array [boolean] of string [5] = (' FAIL', '  OK ') ;
NexD : array [boolean] of byte = (1, 29) ;
var RTC : RTCrec ; Epo : EpochRec ; Year : word ; Day, Next : byte ;
SS : string [25] ;
begin Show(Was+'1999-2005') ;
  with Epo do GetDate(eYr, eMo, eDy, eDoW) ;
  with RTC do for Year := 1999 to 2005 do for Day := 28 to 29 do begin
    RTC := Feb[Day] ; rCy := BCD(Year div 100) ; rYr := BCD(Year mod 100) ;
    SS := DateTimeStringRTC(RTC) ;
    Next := NexD[(Day=28) and ((Year mod 4) = 0)] ;
    PutRTCdirectly(RTC) ;
    repeat ShowTimers ; GetRTCdirectly(RTC) until rSc=$02 ;
    UpShow(SS+' -> '+DateTimeStringRTC(RTC)+Ans[Next=DCB(rDy)]) ;
    if (Year mod 4)>0 then BREAK ;
    end ;
  with Epo do SetDate(eYr, eMo, eDy) ;
  end {LeapRTC} ;

const
Cstr39 = 'Check RTC Leap Years 1999-2005' ;
Str39 : string [Length(Cstr39)] = Cstr39 ;
Job39 : OpT = (Last:@Job38; PGen:@Str39; Task:LeapRTC; Comm:'LEAPRTC') ;


procedure Font(var Cmnd : S80) ; FAR ;
begin {$IFDEF FONT} TextMode(LastMode xor Font8x8) ; SetScreen ;
  {$ELSE} UpShow('Font change not available.') ; {$ENDIF}
  end {Font} ;

const
Cstr40 = 'Toggle 25/50 line screen mode' ;
Str40 : string [Length(Cstr40)] = Cstr40 ;
Job40 : OpT = (Last:@Job39; PGen:@Str40; Task:Font; Comm:'FONT') ;


procedure DSB(var Cmnd : S80) ; FAR ;
var B, S, T : byte ;
const OI : array [boolean] of char = '01' ;
S8 : string [8] = '76543210' ;
begin
  WaitForUIPlowCLI ; Port[$70] := $0E ; S := Port[$71] ; STI ;
  Show(' DSB bits: 7 PwrFail; 6 ChkSumFail; 5; 4; 3; 2 BadTime; 1; 0;') ;
  T := S ;
  for B := 8 downto 1 do begin S8[B] :=OI[Odd(T)] ; T := T shr 1 end ;
  UpShow(' Diagnostic Status Byte is $'+Hex2(S)+' '+S8) end {DSB} ;

const
Cstr41 = 'Inspect Diagnostic Status Byte, at CMOS $0E; see Ralf Brown List' ;
Str41 : string [Length(Cstr41)] = Cstr41 ;
Job41 : OpT = (Last:@Job40; PGen:@Str41; Task:DSB; Comm:'DSB') ;


function RTCtoTix(const RTC : RTCrec) : longint ;
begin with RTC do
    RTCtoTix := ( (longint(word(DCB(rHr))*60+DCB(rMi))*60+DCB(rSc))
    * (DayTix div 80) ) div (86400 div 80) end {RTCtoTix} ;


procedure CompRate(var Cmnd : S80) ; FAR ;
var rRTC : RTCrec ; RTC0, RTC, Tix0, Tix, X : longint ;
S9a, S9b : string [9] ; S80 : string [80] ;
B, XB : boolean ;
begin Show(
    ' CompRate - push a key to stop.  $4CCE=19663 Ticks = 18 mins exactly.') ;
  Scroll ;
  repeat ShowTimers ;
    GetRTCdirectly(rRTC) ; Tix := Get406C ;
    RTC := RTCtoTix(rRTC) ; Str(RTC:9, S9a) ; Str(Tix:9, S9b) ;
    S80 := DateTimeStringRTC(rRTC)+S9a+'   DOS:'+S9b ; Show(S80) ;
    XB := B ; B := (RTC mod (DayTix div 80))=0 { exact seconds } ;
    if B and not XB then begin X := RTC-Tix ;
      if X>+(DayTix div 2) then Dec(X, DayTix) ;
      if X<-(DayTix div 2) then Inc(X, DayTix) ;
      Str(X:9, S9a) ; Show(S80+'   Diff:'+S9a+' Ticks') ; Scroll end ;
    until KeyPushed ;
  end {CompRate} ;

const
Cstr42 = 'Compare RTC & MSDOS clock rates - CPU hog.' ;
Str42 : string [Length(Cstr41)] = Cstr42 ;
Job42 : OpT = (Last:@Job41; PGen:@Str42; Task:CompRate; Comm:'COMPRATE') ;


function FindCmnd(const Cmnd : S80) : POpT ;
var Pop : POpT ;
begin Pop := @Job42 { Last of above chain } ;
  repeat
    with Pop^ do if Copy(Cmnd, 1, Length(Comm))=Comm then BREAK ;
    Pop := Pop^.Last until Pop=NIL ;
  FindCmnd := Pop end {FindCmnd} ;


procedure DoTest(var Cmnd : S80) ;
var Pop : POpT ;
begin
  while (Cmnd>'') and (Cmnd[1]<=Sp) do Delete(Cmnd, 1, 1) ;
  if Cmnd='' then begin Remind(CommandList) ; EXIT end ;
  Cmnd := Cmnd + Sp ; Was := Cmnd + ': ' ;
  Scroll ;
  Pop := FindCmnd(Cmnd) ;
  if Pop<>NIL then with Pop^ do if Pos('?', Cmnd)=0 then
    begin Delete(Cmnd, 1, Length(Comm)) ; Task(Cmnd)
      end else Show('?'+Comm+': '+PGen^) ;
  end {DoTest} ;


function Extract(const R : S80 ; C : byte) : S80 ;
var S : S80 ;
begin S := '' ;
  while not (R[C] in [Sp, ',', ';']) do Dec(C) ;
  repeat Inc(C) ;
    if (C>Length(R)) or (R[C] in [Sp, ',', ';']) then BREAK ;
    S := S + UpCase(R[C]) until false ;
  Extract := S+Sp end {Extract} ;


procedure CEASE ;
begin GoXY(0, LastScreenRow) ; Write(^M^J'Done.') ; HALT end {CEASE} ;


procedure JaceCrouch(var Cmnd : S80) ;
const Col : byte = 9 ; Row : byte = Low(HelpList) ;
var KW : word ; Pop : POpT ;
begin ShowCmnd(
    ' '#24' '#25' '#27' '#26' ^'#27' ^'#26' Home End Tab Enter', Co2) ;
  repeat
    Pop := FindCmnd(Extract(CommandList[Row], Succ(Col))) ;
    if Pop<>NIL then with Pop^ do
      WrScr(Pred(LastScreenRow), '?'+Comm+': '+PGen^, Co6) ;
    GoXY(Col, Row+CmdLine-1) ;
    repeat ShowTimers until KeyPushed ;
    KW := GetKbd ;
    case Lo(KW) of
      0 : case Hi(KW) of
        71 : {Home} Col := 9 ;
        72 : {up} if Row>Low(HelpList) then Dec(Row) ;
        75 : {left} if Col>9 then Dec(Col) ;
        77 : {right} if Col<79 then Inc(Col) ;
        79 : {End} Col := 79 ;
        80 : {down} if Row<Pred(High(HelpList)) then Inc(Row) ;
        115 : {^left} begin
          while (Col>9) and not (CommandList[Row, Succ(Col)] in [',', ':'])
            do Dec(Col) ;
          if CommandList[Row, Succ(Col)]=',' then begin
            Dec(Col) ;
            while (Col>9) and not (CommandList[Row, Succ(Col)] in [',', ':'])
              do Dec(Col) ;
            end ;
          while (Col<79) and (CommandList[Row, Succ(Col)] in [Sp, ':', ','])
            do Inc(Col)
            end ;
        116 : {^right} begin
          while (Col<79) and not (CommandList[Row, Succ(Col)] in [',', ';'])
            do Inc(Col) ;
          while (Col<79) and (CommandList[Row, Succ(Col)] in [Sp, ','])
            do Inc(Col) ;
          end ;
        end {case Hi} ;
      3 : {^C} CEASE ;
      9 : {HT} BREAK ;
      13 : {CR} begin
        Cmnd := Extract(CommandList[Row], Succ(Col)) ; BREAK end ;
      end {case Lo} ;
    until false ;

  end {JaceCrouch} ;


procedure TestLoop ;
const XH = 10 ; Prompt = ' Command ? ' ;
var KW : word ; Ins : boolean ; Cur : byte ; J, Row : 0..XH ;
Cmnd : S80 ; XCmnds : array [1..XH] of S80 ;
begin FillChar(XCmnds, SizeOf(XCmnds), #0) ;
  UpShow(' Read this block now; once it''s gone, you don''t get it again.') ;
  UpShow(' Command set is given in the block below, after colons;'+
    ' precede Hex args with $.') ;
  UpShow(' Type in (editable); or Tab, arrows, Enter, complete, Enter;'+
    ' or up/down History.') ;

  repeat Cmnd := '' ; Cur := 1 ; Row := 0 ; Ins := true ;

    repeat ShowCmnd(Prompt+Cmnd, Co2) ;
      Remind(CommandList) ;
      GoXY(Pred(Length(Prompt))+Cur, CmdLine) ;
      repeat ShowTimers until KeyPushed ;
      KW := GetKbd ;
      case Lo(KW) of
        0 : case Hi(KW) of
          71 : {Home} Cur := 1 ;
          72 : {up} if Row<XH then begin
            Inc(Row) ; Cmnd := XCmnds[Row] ; Cur := Succ(Length(Cmnd)) end ;
          75 : {left} if Cur>1 then Dec(Cur) ;
          77 : {right} if Cur<=Length(Cmnd) then Inc(Cur) ;
          79 : {End} Cur := Succ(Length(Cmnd)) ;
          80 : {down} if Row>1 then begin
            Dec(Row) ; Cmnd := XCmnds[Row] ; Cur := Succ(Length(Cmnd)) end ;
          82 : {Insert} Ins := not Ins ;
          83 : {Del} if Cur<=Length(Cmnd) then Delete(Cmnd, Cur, 1) ;
          end {case Hi} ;
        3 : {^C} CEASE ;
        8 : {BS} if Cmnd>'' then begin Dec(Cur) ; Delete(Cmnd, Cur, 1) end ;
        9 : {HT} begin JaceCrouch(Cmnd) ; Cur := Succ(Length(Cmnd)) end ;
        13 : {CR} BREAK ;
        else begin
          if not Ins then Delete(Cmnd, Cur, 1) ;
          Insert(UpCase(char(Lo(KW))), Cmnd, Cur) ; Inc(Cur) end ;
        end {case Lo} ;
      until false ;

    if Cmnd='' then CONTINUE ;
    if Cmnd[1]='Q' then CEASE ;
    if Cmnd<>XCmnds[1] then begin
      for J := XH downto 2 do XCmnds[J] := XCmnds[Pred(J)] ;
      XCmnds[1] := Cmnd end ;
    DoTest(Cmnd) ;
    until false ;

  end {TestLoop} ;


procedure Try ;
var RTC : RTCrec ; E : EpochRec ; K : word ;
begin
  with E do begin
    GetDate(eYr, eMo, eDy, K) ; GetTime(eHr, eMi, eSc, K) end ;
  Writeln(DateTimeStringDOS(E)) ;
  GetRTCdirectly(RTC) ;
  Writeln(DateTimeStringRTC(RTC)) ;
  end {Try} ;



procedure Setup ;
const DilBool : boolean = false ;
var J, K : word ; ParStr : S80 ; Regs : Registers ;
Mo : byte ; S : string [1] ;
begin Randomize ; SetScreen ;

  for K := 1 to ParamCount do begin ParStr := ParamStr(K) ;
    if Length(ParStr)<2 then ParStr := '/?' ;
    if not( ParStr[1] in ['-', '/']) then begin
      Write('** Error in Parameter ', K) ; HALT end ;
    Delete(ParStr, 1, 1) ;
    for J := 1 to Length(ParStr) do ParStr[J] := UpCase(ParStr[J]) ;
    case ParStr[1] of
      'B' : BootSel := ParStr[2] ;
      'C' : begin ParStr := Copy(PString(Ptr(PrefixSeg, $80))^, 3, 255) ;
        DoTest(ParStr) ; HALT end ;
      'D' : ;
      'E' : Exe := true ;
      'F' : FindDayCount(ParStr{not used}) ;
      'N' : GlobalMax := GetL(ParStr) ;
      'P' : if ParStr='PS2' then begin CCinCMOS := $37 {IBM PS/2} ;
        Insert(' PS2RDC, PS2WDC;',
          CommandList[High(CommandList)-1], 255) end ;
      'S' : begin BootSync := true ;
        BootIncDel := ParStr[2] ; BootDelay := GetL(ParStr) ;
        if BootDelay=0 then BootDelay := Random(MaxDel) ;
        end ;
      'V' : begin S := Copy(ParStr, 2, 1) ;
        if S='+' then VladoProc := true ;
        if S='-' then VladoProc := false ;
        end ;
      else begin
        Writeln(ParamStr(K), ^M^J'INT_TEST ' +
          '[/F] [/PS2] [/N<times>] [/Bx] [/S<#>] [/Dilation] [/Vñ]') ;
        HALT end ;
      end ;
    DilBool := ParStr='DILATION' ;
    end {K} ;

  with DosVer do begin
    asm  mov ah,$30 ; Int $21 ; mov DosVer.Maj,al ; mov DosVer.Min,ah  end ;
    Write(' DOS version ', Maj, '.', Min, ' detected') ;
    if Maj=4 then GetDTA := $5D0B else GetDTA := $5D06 ;
    if Maj<4 then DTAPad := $2E else DTApad := $30 ;
    if Maj>=4 then begin
      asm  mov ax,$3305 ; xor dl,dl ; int $21 ; mov Mo,dl  end ;
      BootDev := char(64+Mo) ;
      Write('; booted from drive ', BootDev) ;
      end ;
    Writeln('.') ;
    end ;

  DaysFromFeb[BaseMo] := 0 ; for Mo := BaseMo to Pred(LastMo) do
    DaysFromFeb[Mo+1] := DaysFromFeb[Mo] + DaysInMonth[Mo] ;

  if DilBool then Dilate ;

  ClockRecPtr := NIL ;
  with Regs do begin AX := GetDTA ; MsDos(Regs) ;
    if (Flags and FCarry)<>0 then Writeln('DTA Location Error ', AX) else
      ClockRecPtr { Swap-state uncertain } := Ptr(DS, SI+DTApad) ;
    end ;
  Writeln(' ClockRecPtr (into SDA) = ', PtrS(ClockRecPtr)) ;

  end {Setup} ;


BEGIN Writeln(^M^J, ID) ; Send := Wrte ;
Setup { may call Dilate; may reboot there } ;
Try ;
Write('The documentation is in the PAS file - read it. <cr>') ; WaitKbd ;

Send := Show ;
Wipe ;
ShowUp(ID) ;
ShowUp(' Beware of possible side-effects of calls.') ;
ShowUp(' Dangerous to change date/time if other processes are running!') ;
Show  (' Dangerous under Windows 3/95/98; maybe impossible under NT!') ;

TestLoop ;

ShowCmnd(' Finished.  ' +
  'It may be wise now to re-boot, to assure consistency. <cr>', Co3) ;
WaitKbd ;
GoXY(0, LastScreenRow) ; WrScr(LastScreenRow, '', $0700) ;
END.


This is a program to enable investigation of PC time/date properties.
It is written for Borland/Inprise Turbo Pascal 7.01, which can still be
purchased quite cheaply (though I use BP7.01, which sadly cannot be).

It is not itself a Y2k, rollover &c, tester, although it has
routines which can be used in that.

There is no documentation other than the code and what follows it, except
for the text file by it on my Web site.

Virus scan your system, and this program, before using this program;
include any floppies in the scan.

It is unsafe to change the date or time if other processes may be running.
Windows is another process.  The program may fail in WinNT.  It might be
either unwise or interesting to make changes near RTC or DOS date rollover
or summer-time changes.

Other than the explicit Time/Date & Exec ones requested by the
corresponding commands, the program no longer uses any MSDOS calls or
date/time related BIOS ones, except at the start and in the DayCount search.

Ralf Brown, INTER60, CMOS.LST : Century Byte Locations :
 $32 IBM PC ; $37 IBM PS/2 ; $7F AMD - default is $32.

FindDayCount requires the CLOCK$ driver data to have been loaded low;
its call is now optional.  Windows 98, &c, may defeat its present method.
Unfortunately, the method causes MSDOS date/time to be written to CMOS.

The CLOCK$buf functions do not call the driver; they just use the buffer.
Longword $046C is MSDOS's prime time count; 18.2Hz from midnight;
DayCount is MSDOS's prime date; zero is 1980-01-01.

Presently assumes Colour, 80 cols, or Amstrad PPC640 mono.

DOS 4 untested; I have just 3.3, 6.20, WfWg3.11, Win98.

For help on "command", type "command ?".
Undisplayed commands can easily be seen by reading procedure DoTest.

In general, input values are not range-checked for validity.

Now with Up Down Left Right Home End Insert Delete, much as DOSKEY.
Tab shifts to a menu-picking mode.

Command ART N is Accelerated Rollover Test, to examine the utility of the
remarkable RJ-P scheme.  RJ-P's scheme corresponds to N=1, which is
expected to be no better than N=0.  The acceleration is invisible to the
system.

OPTIONS : introduced in Command line by "/" or "-".

/F = call FindDayCount at starttup
/N = number of results stored by RRRTC, TIMEDRTC.
/PS2 = PC is PS/2 - functions are as yet untested, as I have no PS/2.
/C (first) = use rest (CAPS) as menu command - as yet untidy.
/Vñ = use Vlado's all-asm proc in RRRTC (from 1999-07-23; default ON).

For a possible TD test, read the code above, procedure "Dilate", etc.
If the program is called with final option "/dilation", it will write to
"dilation.log" in the current directory
and (unless a key is pressed) reboot.  Consider the effect
of calling it thus from DOS autoexec.bat, perhaps on a boot floppy.
Option /b<letter> chooses boot style (default is A);
  /b@ : no boot
  /bA : hard hard boot :- Electrical reset line pulsed
  /bB : forge kbd boot :- CtrlAltDel simulated
  /bC : soft cold boot :- $40:$72 := $0000 ; JMP $FFFF:$0000
  /bD : soft warm boot :- $40:$72 := $1234 ; JMP $FFFF:$0000
  /bE : requested boot :- ask user for power cycle
  /bF : requested boot :- ask user for reset button
  /bG : requested boot :- ask user for CtrlAltDel
  /bH : PS/2 MCA POS boot :- toggle LSB - works on JRS's Tandon 486/33 !
  /bI : boot by timeswitching power :- user must set up switch
  /bJ : call Int $19 :- dubious
  /bK : unspecified external :- entry provided merely to avoid lying
  /bL : call APM power-off routine :- largely untested
Option /s<number> chooses boot synced from end of UIP with a delay of
<number>/(4*2*256*18.2) seconds = <number>*0.027 ms; 0 gives a random delay.
If the character after "s" is + or -, the figure is an increment/decrement.
Styles E F G I K end in a wait-loop; the choice of 5 is merely for logging.
Option /e shells to DOS before re-boot, allowing normal work.

In the log file, the figure after the date/times is the DOS date/time
in units of 16/18.2 seconds, and the following figure is the difference
from the previous value.  But days are mod 16384, to prevent overrange;
breaks are at 0000h on 2024-11-09, 2069-09-18.


Vlado Nikiforov <vladon@mail.otel.net> sent E-mail 1999-05-01, providing
inline assembler versions of ReadUIPbit, WaitForNotUIP, WaitForUIPend,
and GatherData; in GatherData, the old code has been maintained compilable
lest there be need to monitor YY MM DD as well as hh mm ss.  The new
GatherData has some 15% better resolution on my Tandon 486/33.  He also
provided CollectData, installed mid-July 1999, which again improves RRRTC;
at the same time, wait-for-RTC was cleaned up.


Now read the source code above again; try it at your own risk.

BP has an option allowing 286 instructions, which I normally have enabled;
asm code therefore needs to be restricted to that level.

Compiling : FONT requires either the TextSet or Crt unit, which are
not otherwise needed.

END of text for users.


To turn PC off with APM :
UNTESTED : asm  mov ax,5307h ; mov bx,1 ; mov cx,3 ; int 15h  end ;

READ:
asm  mov dx,$70 ; mov al, SubAddr ;
  cli ; out [dx], al ; inc dx ; in al,[dx] ; sti  end ;

Advice from clax86 ~1999-07-11 is that padding is almost certainly never
needed between RTC instructions, but that, if used, "jmp short $+2"
(use jmp @1 ; @1: for BP/TP).