program readid; (*$c-*)
(* Diskettenanalyse - findet alle formatierten Sektoren einer Diskette
   (c) 18-Feb-89 Helmut Tischer, Moosburg a.d. Isar

   Doppelsteps: funktionieren nur bei BankCPM
   Doppelseitig: funktioniert nur bei vortex 44K+62K CP/M und BankCPM
   einseitig, ohne Doppelsteps: geht bei Amstrad, Vortex, BankCPM CP/M 2.2
*)   
const maxid = 31;
type resultfeld = array[0..maxid, 0..6] of byte; msgstr = string[80];
var geraet, drive, track, side, flagbyte: byte;
    continue, twoside: char;
    endofdisk: boolean;
    flgptr:integer;

(* Funktionen zum Direktzugriff auf Disckontroller uPD765, Vers. 24.08.1986 *)
const FDCPOR:integer=$fb7e;MOTPOR:integer=$fa7e;MOTON:byte=1;MOTOFF:byte=0;
computertyp:string[13]='Schneider CPC';
function fdccall(var comman,execut,result):byte;
var busy:byte;begin
Inline($ED/$4B/FDCPOR/$ED/$5B/COMMAN/$2A/RESULT/$E5/$2A/EXECUT/
$ED/$78/$87/$30/$FB/$E6/$E1/$3E/$FF/$20/$62/$1A/$13/$0C/$ED/$79/$0D/$3E/$05/
$3D/$20/$FD/$ED/$78/$87/$30/$FB/$87/$38/$21/$87/$38/$0D/$3E/$0A/$3D/$20/$FD/
$ED/$78/$E6/$10/$20/$DF/$18/$3B/$7E/$0C/$ED/$79/$0D/$23/$ED/$78/$87/$30/$FB/
$E6/$40/$20/$F1/$18/$12/$87/$30/$0F/$0C/$ED/$78/$0D/$77/$23/$ED/$78/$87/
$30/$FB/$E6/$40/$20/$F1/$E3/$ED/$78/$87/$30/$FB/$E6/$20/$28/$0D/$0C/$ED/$78/
$0D/$77/$23/$3E/$04/$3D/$20/$FD/$18/$EA/$E3/$ED/$78/$E6/$0F/$C1/$32/BUSY);
fdccall:=busy end;
procedure fdcmotor(flgmot: byte);begin
Inline($ED/$4B/MOTPOR/$3A/MOTON/$5F/$3A/MOTOFF/$57/$3A/FLGMOT/$A7/$7A/$28/$01/
$7B/$ED/$79)
end;
procedure fdcinterrupt(flgint: byte);begin
Inline($3A/FLGINT/$A7/$28/$03/$FB/$18/$01/$F3)
end;

(* Byte in hexadezimale Schreibweise umwandeln *)
type hexstring=string[2];
function convhex(z:byte):hexstring;
var erg:hexstring;begin
inline($21/erg/$3a/z/$36/$02/$4f/$1f/$1f/$1f/$1f/$e6/$0f/$c6/$90/$27/$ce/$40/
$27/$23/$77/$79/$e6/$0f/$c6/$90/$27/$ce/$40/$27/$23/$77);
convhex:=erg end;

(* CPC-XBIOS-Routinen aus Turbo-Pasal aufrufen fuer CP/M 2.2 *)
type register = record f,a:byte; bc,de,hl:integer end;
procedure xbios(var regvar:register;adress:integer);
 var spvar:integer;
begin
 if mem[0002] <$C0
  then inline($2a/adress/$22/*+19/$ed/$73/spvar/$f3/$ed/$7b/regvar/$f1/$c1/
       $d1/$e1/$fb/$cd/$9b/$be/$00/$00/$f3/$e5/$d5/$c5/$f5/$ed/$7b/spvar/$fb)
  else inline($ed/$73/spvar/$f3/$ed/$7b/regvar/$f1/$c1/$d1/$e1/$ed/$7b/spvar/
       $fb/$d9/$21/*+$0d/$e5/$2a/adress/$11/$b9/$35/$19/$e5/$d9/$c9/$f3/$08/
       $d9/$2a/regvar/$11/$08/$00/$19/$f9/$d9/$08/$e5/$d5/$c5/$f5/$ed/$7b/
       spvar/$fb)
end;

procedure upcaseread(var ch: char);
begin
 read(kbd,ch);
 ch := upcase(ch);
 if ch=^C then begin
                writeln('^C ...Abgebrochen');
                mem[flgptr]:=flagbyte;
                halt
               end
end;

procedure seektrack(drive, zylinder: byte);
var regvar: register;
begin
  regvar.de := zylinder shl 8 + drive;
  xbios(regvar,$BE92);
  if(regvar.f and 1) = 0
   then begin
         writeln('FEHLER: Zylinder nicht gefunden.');
         mem[flgptr] := flagbyte;
         halt
        end
end;

procedure readids(drive, side, dens: byte; var anzahl, start: byte;
  var idfeld: resultfeld);
var readid: array[0..1] of byte; result: array[0..6] of byte; dummy: byte;
begin
  fdcinterrupt(0);
  readid[0]:=(dens and 1)shl 6+10;readid[1]:=(drive and 3)+(side and 1)shl 2;
  dummy := fdccall(readid[0], dummy, result[0]); anzahl := 0; start := 0;
  if (result[0] and 192) = 0 then
    repeat
      dummy := fdccall(readid[0], dummy, idfeld[anzahl,0]);
      if idfeld[anzahl, 5]<idfeld[start,5]then start:=anzahl;anzahl:=anzahl+1
    until idfeld[anzahl - 1, 5] = result[5];
  fdcinterrupt(1);
end;


procedure auswahl(var drive: byte; var twoside: char; var geraet: byte);
var continue: char; i:integer; com: boolean;
 procedure nocommand;
 begin
  if com then writeln('Kommandozeilenparameter fehlt.');
  com:=false
 end;
begin
  com:=true;
  if (mem[$5C]=1) or (mem[$5C]=2)
   then drive:=mem[$5C]-1
   else begin
         nocommand;
         write('Welches Laufwerk analysieren? (A/B) ');
         repeat
          upcaseread(continue);
         until (continue = 'A') or (continue = 'B');
         writeln(continue);
         drive := ord(continue) - ord('A')
        end;
  flgptr := $FC00 + drive shl 4 + 10;
  flgptr := mem[flgptr] + mem[flgptr+1] shl 8 + 24;
  flagbyte := mem[flgptr];
  mem[flgptr] := flagbyte and $FE;
  if (flagbyte and 4) = 0
   then twoside:='N'
   else begin
         if (mem[$5D]=ord('D')) or (mem[$5D]=ord('S'))
          then begin if mem[$5D]=ord('D') then twoside:='J'
                                          else twoside:='N'
               end
          else begin
                nocommand;
                write('Doppelseitig analysieren ? (J/N) ');
                repeat
                 upcaseread(twoside)
                until (twoside = 'J') or (twoside = 'N');
                writeln(twoside)
               end
        end;
  if (flagbyte and 8) <> 0
   then begin
         if (mem[$5E]=ord('8')) or (mem[$5E]=ord('4'))
          then begin if mem[$5E]=ord('8')
                      then mem[flgptr] := mem[flgptr] and $FD
                      else mem[flgptr] := mem[flgptr] or $02
               end
          else begin
                nocommand;
                write('Doppelschritte ? (J/N) ');
                repeat
                 upcaseread(continue);
                until (continue = 'J') or (continue = 'N');
                writeln(continue);
                if continue='N' then mem[flgptr] := mem[flgptr] and $FD
                                else mem[flgptr] := mem[flgptr] or $02
               end
        end;
  if (flagbyte and $20) = 0 
   then geraet := drive
   else begin (* externes Laufwerk - Ger{teadresse suchen *)
         i := $F463;
         while (i<>$FBC8) and ((mem[i]<>$E6) or (mem[succ(i)]<>$FC) or 
               (mem[succ(succ(i))]<>$F6)) do
          i := succ(i);
         if i<>$FBC8 then geraet := mem[i+3] and $03
                     else begin
                           writeln('Laufwerksadresse nicht gefunden! -> ',
                                    'internes Laufwerk verwenden.');
                           geraet := drive
                          end
        end;
  write('Bitte Diskette in Laufwerk ',chr(ord('A')+drive),
        ' einlegen und eine Taste druecken ');
  while keypressed do read(kbd,continue);
  repeat until keypressed; writeln; upcaseread(continue);
  writeln; write('--Position---    ');
  writeln('-----------------Werte in den Sektor-IDs------------------')
end;

function spurinhalt(drive, side: byte): boolean;
var continue, density: char; idfeld: resultfeld; max, st, i: byte;
begin
  spurinhalt := false;
  density := 'D'; readids(drive, side, 1, max, st, idfeld);
  if max=0 then begin density:='S';readids(drive,side,0,max,st,idfeld)end;
  if max = 0
    then begin write('nicht formatiert. Weitersuchen? (J/N) ');
               while keypressed do read(kbd,continue);
               repeat
                upcaseread(continue);
               until (continue='J') or (continue='N');
               write(continue);
               if continue='N' then spurinhalt := true; end
    else begin
           write('Track ',convhex(idfeld[0,3]),' Side ',convhex(idfeld[0,4]),
                 ' ',density, 'D Size ',convhex(idfeld[0,6]),' Sec');
           for i:=st to st+max-1 do write(' ',convhex(idfeld[i mod max,5]))
         end;
  writeln
end;

begin
  writeln('==> Diskettenanalyse fuer BankCPM <==');
  auswahl(drive,twoside,geraet);
  track := 0; side := 0;
  repeat
    write('Cyl ', convhex(track), ' Head ', side, ' -> ');
    seektrack(drive, track);
    endofdisk := spurinhalt(geraet, side);
    if twoside='J'then side:=(side+1)and 1;
    if side=0 then track:=track+1;
    while keypressed do
     begin
      read(kbd,continue); if continue=^S then upcaseread(continue)
     end
  until endofdisk;
  mem[flgptr] := flagbyte
end.