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

 type register = record f,a: byte; bc,de,hl,ix: integer end;
      xdpb = record
              spt: integer;
              bsh,blm,exm: byte;
              dsm,drm: integer;
              al0,al1: byte;
              cks,off: integer;
              psh,phm: byte;
              sid,trk,sec,fsc: byte;
              siz: integer;
              grw,gfo,rdm,aut: byte
             end;
      xdpbPtr = ^xdpb;
      drvtab = array[0..15] of integer;
      drvtabptr = ^drvtab;

 var ch, taste: char;
     drive, form: integer;
     line: boolean;
     drives: drvtabptr;
     para: xdpbptr;
     regvar: register;
     xdph: record
            wrsec,rdsec,login,init:integer;
            unit, typ: byte;
            xlt: integer;
            scratch: array[0..8] of byte;
            media: byte;
            dpb, csv, alv, dirbcb, dtabcb, hash: integer;
            hbank: byte
           end;

 const name: array[0..2] of string[13] =
              ('Fixed','System CPC','Data-Only CPC');

 (* XBIOS-Routine aufrufen. Verwendet Modus-Umschaltroutine bei BIOS+5Ah *)
 procedure xbios(var regvar: register; adress: integer); var spvar: integer;
 begin
  inline($2a/$01/$00/$11/$57/$00/$19/$22/*+25/$2a/adress/$22/*+21/$ed/$73/
         spvar/$f3/$ed/$7b/regvar/$f1/$c1/$d1/$e1/$DD/$E1/$fb/$cd/$00/$00/$00/
         $00/$f3/$DD/$E5/$e5/$d5/$c5/$f5/$ed/$7b/spvar/$fb)
 end;

 (* Bankuebergreifendes Speicherkopieren mit BIOS+57h und BIOS+4Bh *)
 procedure xmove(sbnk,dbnk,source,dest,len: integer);
 begin
  inline($11/$54/$00/$FD/$2A/$01/$00/$FD/$19/
         $ED/$4B/sbnk/$3A/dbnk/$47/
         $CD/*+22/
         $11/$48/$00/$FD/$2A/$01/$00/$FD/$19/
         $ED/$5B/source/$2A/dest/$ED/$4B/len/
         $FD/$E9)
 end;

 procedure readkbd(var ch: char);
 begin
  read(kbd,ch);
  if ch=#03 then begin writeln; halt end
 end;

function selformat(para: xdpbptr; var line: boolean): integer;
 var ch: char;
     regvar: register;
begin
 if para^.aut=255
  then selformat := 0
  else if (mem[$005D]>=ord('1')) and (mem[$005D]<=ord('2'))
        then selformat := ord(mem[$005D]-ord('0'))
        else begin
              line := true;
              write('welches Format? (1=',name[1],' 2=',name[2],') ');
              repeat readkbd(ch) until (ch='1') or (ch='2');
              writeln(ch);
              with regvar do begin a:=ord(ch)-ord('0'); ix:=ord(para) end;
              xbios(regvar,$0095);
              selformat := ord(ch)-ord('0')
             end
end;

 procedure formatdisk(drive:integer; para: xdpbptr);
  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 (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] := psh
     end;
    for zylinder:=0 to trk-1 do
     for head:=0 to sid 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 sid = 1 then regvar.de := $E5 + zylinder shl 9 + head shl 8
                  else regvar.de := $E5 + zylinder shl 8;
       regvar.bc := 256 + drive;
       regvar.hl := addr(formdat);
       regvar.ix := ord(para);
       xbios(regvar,$008F); (* 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 CP/M 3.0 OR HIGHER'); halt end
 end;

 function seldrive(var line: boolean): char;
  var ch: char;
 begin
  if mem[$005C]<>0
   then seldrive:= 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);
         seldrive:=ch
        end
 end;

 procedure waitdisk(ch: char);
  var dummy: char;
 begin
  write('Bitte leere Diskette in Laufwerk ',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 Amstrad CP/M plus');
 writeln;
 line := false;
 ch := seldrive(line);
 drives := ptr(bioshl(21));
 xmove(0,1,drives^[ord(ch)-ord('A')] - 10,addr(xdph),35);
 form := selformat(ptr(xdph.dpb), line);
 repeat
  if line then writeln;
  line := true;
  waitdisk(ch);
  write('Format = ',name[form],', Formatieren von Laufwerk ',ch);
  formatdisk(xdph.unit, ptr(xdph.dpb));
  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.
*%	
·/% !"#–*%&'()*+,-./0123456789:;<=>?ÿÿ