{$C-,U-,R-,A-}
program HdcTest;
const
  {$I HDCDEF.INC}
type
  Wrkstring = string[80];
  Str10     = string[10];
var
  Hdcok     :boolean;
  Ch        :char;
  Gap3_Len  :integer;
  Sekt_Size :integer;
  Buffer    :array[1..1024] of byte;
  Maxtrack  :integer;
  Maxsek    :integer;

{$I HDCROUT.INC}

procedure WriteHex(B :byte);
var
  B1 :byte;

  procedure WriteNibble(B :byte);
  begin
    B:=B+$30;
    if B > $39 then B:=B+7;
    write(chr(B))
  end;

begin
  B1:=B shr 4; WriteNibble(B1);
  B1:=B and $0F; WriteNibble(B1)
end;

procedure DispBit(B,N :integer);
var
  I,T :integer;
begin
  T:=1;
  for I:=1 to N do
  begin
    T:=B shr (N-I);
    if (T and 1) = 1 then write('1') else write('0')
  end
end;

procedure WaitKey;
var
  Ch1,Ch2 :char;
begin
  if keypressed then
  begin
    read(kbd,Ch1);
    if upcase(Ch1) = 'W' then
      repeat
        read(kbd,Ch2)
      until upcase(Ch2) = 'G'
  end
end;

function CheckPatram(Seklen :integer):boolean;
var
  I,D    :integer;
  S,Ok,F :boolean;
  Pat    :byte;
  Ch     :char;
begin
  write(' Testing Buffer-Ram with Pattern ... ');
  Ok:=true;
  F:=true;
  Pat:=0;
  repeat
    for I:=1 to Seklen do port[Hdcdata]:=Pat;
    S:=true;
    for I:=1 to Seklen do
    begin
      D:=port[Hdcdata];
      S:=S and (D = Pat);
      if not S then Ok:=S
    end;
    if not S then
    begin
      if F then
      begin
        writeln;
        F:=false
      end;
      write('Buffer Error : Pattern = ');
      WriteHex(Pat);
      write(' = ');
      DispBit(Pat,8);
      write(' -> Data = ');
      WriteHex(D);
      write(' = ');
      DispBit(D,8);
      writeln;
      Waitkey
    end;
    Pat:=Pat+1
  until (Pat > 255) or not S or keypressed;
  if keypressed then read(kbd,Ch);
  if Ok then writeln('Buffer is OK') else writeln('Buffer is not OK');
  CheckPatram:=Ok
end;

function CheckAdrram(Seklen :integer):boolean;
var
  I        :integer;
  D        :byte;
  Ok,First :boolean;
begin
  writeln;
  write(' Testing Buffer-Ram with Adress-Data ... ');
  for I:=1 to Seklen do port[Hdcdata]:=lo(I);
  Ok:=true;
  for I:=1 to Seklen do
  begin
    D:=port[Hdcdata];
    Ok:=Ok and (D = lo(I));
    if D <> lo(I) then
    begin
      if First then
      begin
        writeln;
        First:=false
      end;
      write(' Adress = ');
      WriteHex(hi(I));
      WriteHex(lo(I));
      write(' Data = ');
      WriteHex(lo(I));
      write(' -> ');
      WriteHex(lo(D));
      writeln
    end
  end;
  if Ok then writeln('Buffer is OK') else writeln('Buffer is not OK');
  CheckAdrram:=Ok
end;

procedure Setsdh(Drv,Head,Seklen :integer);
var
  I,S :integer;
begin
  I:=Head and (Anzahl_Koepfe-1);
  I:=I or ((Drv and $03) shl 3);
  case Seklen of
    128  : S:=$60;
    256  : S:=$00;
    512  : S:=$20;
    1024 : S:=$40
    else writeln(' Internal Error : Sektorlength incorrect')
  end;
  I:=I or S or 8;
  port[Hdcsdh]:=I;
  if port[Hdcsdh] <> I then
  begin
    writeln;
    write('Error : SDH-Register incorrect : ',I:3,' --> ');
    WriteHex(port[Hdcsdh]);
    writeln
  end
  else
  begin
    writeln;
    writeln(' SDH-Register OK ');
    writeln
  end
end;

function SeekTest(Nt :integer):boolean;
var
  I,J,K :integer;
  Ok    :boolean;
  St    :byte;
  Ch    :char;
begin
  writeln;
  write(' Seek-Test (10 Restore-Seeks) ... ');
  K:=0;
  repeat
    K:=K+1;
    HDC_Wait;
    HDC_Home;
    HDC_Wait;
    St:=port[Hdcstat];
    if (St and 1) <> 0 then
    begin
      Ok:=false;
      St:=port[Hdcerr];
      writeln;
      writeln('Restore failed, Error Code = ',St:2)
    end
    else
    begin
      port[Hdccyl]:=lo(Nt);
      port[Hdccyh]:=hi(Nt);
      port[Hdccmd]:=Seek_CMD;
      HDC_Wait;
      St:=port[Hdcstat];
      if (St and 1) <> 0 then
      begin
        St:=port[Hdcerr];
        writeln;
        writeln('Seek failed, Error Code = ',St:2);
        Ok:=false
      end
      else
      begin
        write('+');
        St:=port[Hdcstat];
        if (St and 1) <> 0 then
        begin
          write('Seek to Track 0 failed, Error Code = ');
          WriteHex(St);
          writeln;
          Ok:=false
        end
        else Ok:=True
      end
    end
  until (K > 10) or keypressed;
  if keypressed then read(kbd,Ch);
  if Ok then writeln(' Seek-Test OK');
  SeekTest:=Ok
end;

function Scanid(Tr :integer):boolean;
var
  I,J :integer;
  Ok  :boolean;
begin
  Ok:=true;
  writeln;
  write(' Disk-Read-Test ... ');
  port[Hdccyl]:=lo(Tr);
  port[Hdccyh]:=hi(Tr);
  port[Hdcsek]:=1;
  port[Hdccmd]:=Seek_CMD;
  J:=0;
  while not keypressed and (J = 0) do
  begin
    HDC_Wait;
    port[Hdccmd]:=Scanid_Fast_CMD;
    HDC_Wait;
    I:=port[Hdcstat];
    if (I and 1) = 1 then
    begin
      J:=port[Hdcerr];
      Ok:=false
    end
    else J:=0
  end;
  if Ok then writeln(' Disk-Read-Test OK')
  else
  begin
    writeln(' Error: Disk-Read-Test');
    writeln;
    write(' Error = ');
    WriteHex(J);
    writeln;
    I:=port[Hdcstat];
    write(' Status = ');
    WriteHex(I);
    writeln;
    I:=port[Hdccyh]*256+port[Hdccyl];
    writeln(' Track = ',I);
    I:=port[Hdcsek];
    writeln(' Sektor = ',I)
  end;
  Scanid:=Ok
end;

begin
  clrscr;
  writeln('Test Routinen fuer den Winchester Controller [V 0.1]');
  writeln;
  HDC_Init;
  writeln('Alle Test koennen mit einem Tastendruck beendet werden !');
  writeln;
  Setsdh(0,0,Sektor_Laenge);
  Hdcok:=CheckPatram(2048);
  Hdcok:=Hdcok and CheckAdrram(2048);
  Hdcok:=Hdcok and SeekTest(Anzahl_Zylinder);
  Hdcok:=Hdcok and Scanid(10);
  writeln;
  if Hdcok then writeln('Controller is OK und soweit funktionsbereit')
  else writeln('HDC-Karte fehlerhaft / nicht funktionsbereit');
  writeln;
  writeln('Ende der Test-Routinen');
  HDC_Deselect
end.
