program format2; (*$B+,C-,I-,R-,V-,U-,A+,W1,X-*)
(* (c) 18-Feb-89 Helmut Tischer, Moosburg a.d. Isar *)

(* Version BankCPM/Vortex CP/M 2.2 *)

 type register = record f,a: byte; bc,de,hl: integer end;
      xdpb = record
              spt: integer;
              bsh,blm,exm: byte;
              dsm,drm: integer;
              al0,al1: byte;
              cks,off: integer;
              fsc,sec,
              grw,gfo,fil,
              siz,rec,cur,trk,flg: byte
             end;
      xdpbPtr = ^xdpb;
      drvtab = record
                xlt: integer;
                scratch: array[0..2] of integer;
                dirbuf, dpb, csv, alv: integer;
               end;
      drvtabptr = ^drvtab;

 var ch, taste: char;
     line: boolean;
     dphptr: drvtabptr;
     dpbptr: xdpbptr;

(* CPC-XBIOS-Routinen aus Turbo-Pasal aufrufen fuer CP/M 2.2 *)
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 readkbd(var ch: char);
 begin
  read(kbd,ch);
  if ch=#03 then begin writeln; halt end
 end;

 procedure formatdisk(drive:integer; para: xdpbptr; xlt: integer);
  var regvar: register;
      i, zylinder, head: integer;
      formdat: array[0..26,0..3] of byte;
      ch: char;
 begin
  write(' Zylinder 00 Kopf 0');
  with para^ do
   begin
    for i:=0 to sec-1 do
     begin
      if xlt <> 0
       then formdat[i,2] := fsc + i
       else if (i and 1)=0 then formdat[i,2] := fsc + i shr 1
                           else formdat[i,2] := fsc + i shr 1 + (sec+1) shr 1;
      formdat[i,3] := siz
     end;
    for zylinder:=0 to trk do
     for head:=0 to flg and 1 do
      begin
       write(#8#8#8#8#8#8#8#8#8,zylinder:2,' Kopf ',head:1);
       for i:=0 to sec-1 do
        begin formdat[i,0] := zylinder; formdat[i,1] := head end;
       if (flg and 1) = 1
        then regvar.de := drive + zylinder shl 9 + head shl 8
        else regvar.de := drive + zylinder shl 8;
       regvar.hl := addr(formdat);
       xbios(regvar,$BE8F); (* Spur formatieren *)
       if (regvar.f and 1) = 0 then
        begin
         writeln;
         write('Fehler aufgetreten - Diskette unvollstaendig!');
         exit
        end;
       while keypressed do
        begin
         read(kbd,ch);
         if ch=#03
          then begin
                writeln;
                write('Abgebrochen - Diskette unvollstaendig!');
                exit
               end
        end
      end
   end
 end;

 procedure version;
 begin
  if (bdoshl(12) and $FF) >= $30 then
   begin writeln('Requires Vortex CP/M 2.2'); halt end
 end;

 function seldrive(var line: boolean): char;
  var ch: char;
 begin
  if mem[$005C]>2 then mem[$005C] := 0;
  if mem[$005C]<>0
   then ch := chr(mem[$005C]+ord('@'))
   else begin
         line := true;
         write('In welchen Laufwerk formatieren? (A/B) ');
         repeat
          readkbd(ch); ch:=upcase(ch)
         until (ch='A') or (ch='B');
         writeln(ch)
        end;
  seldrive:=ch
 end;

 procedure waitdisk(ch: char);
  var dummy: char;
 begin
  write('Bitte leere Diskette in Laubwerk ',ch,' einlegen und ',
   'eine Taste druecken ');
  while keypressed do readkbd(dummy);
  repeat until keypressed;
  readkbd(dummy);
  writeln
 end;

begin
 version;
 writeln('erweiterte Disketten-Formatierung fuer Vortex CP/M 2.2');
 writeln;
 line := false;
 ch := seldrive(line);
 dphptr := ptr(bioshl(8,ord(ch)-ord('A')));
 bdos(13);
 dpbptr := ptr(dphptr^.dpb);
 repeat
  if line then writeln;
  line := true;
  waitdisk(ch);
  with dpbptr^ do
   write('Format=(',
         (sec*((((flg and 1)+1)*succ(trk))-off)) shr (3-siz),
         'K Data,',
         succ(blm) shr 3,
         'K Blocks) - Formatieren von Laufwerk ',
         ch);
  formatdisk(ord(ch)-ord('A'), dpbptr, dphptr^.xlt);
  writeln;
  if (mem[$006D] = ord('?')) or (mem[$005D] = ord('?'))
   then taste := 'N'
   else begin
         write('Noch eine Diskette? (J/N) ');
         repeat
          readkbd(taste)
         until (upcase(taste) = 'J') or (upcase(taste) = 'N');
         writeln
        end
 until upcase(taste) = 'N'
end.