{$R-,S-,I-,B-,F-,O+}

{---------------------------------------------------------
 BIOS disk I/O routines for floppy drives. Supports DOS
 real mode, DOS protected mode, and Windows. Requires
 TP6, TPW, or BP7.

 All functions are for floppy disks only; no hard drives.

 See the individual types and functions in the interface of
 this unit for more information. See the FMT.PAS sample
 program for an example of formatting disks.

 For status code definitions, see the implementation of
 function GetStatusStr.

 ---------------------------------------------------------
 Based on a unit provided by Henning Jorgensen of Denmark.
 Modified and cleaned up by TurboPower Software for pmode
 and Windows operation.

 TurboPower Software
 P.O. Box 49009
 Colorado Springs, CO 80949-9009

 CompuServe: 76004,2611

 Version 1.0  10/25/93
 Version 1.1  10/29/93
   fix a dumb bug in the MediaArray check
 ---------------------------------------------------------}

unit BDisk;
  {-BIOS disk I/O routines for floppy drives}

interface

const
  MaxRetries : Byte = 3;          {Number of automatic retries for
                                   read, write, verify, format}

type
  DriveNumber = 0..7;             {Acceptable floppy drive numbers}
                                  {Generally, 0 = A, 1 = B}

  DriveType = 0..4;               {Floppy drive or disk types}
                                  {0 = unknown or error
                                   1 = 360K
                                   2 = 1.2M
                                   3 = 720K
                                   4 = 1.44M}

  VolumeStr = String[11];         {String for volume labels}

  FormatAbortFunc =               {Prototype for format abort func}
    function (Track : Byte;       {Track number being formatted, 0..MaxTrack}
              MaxTrack : Byte;    {Maximum track number for this format}
              Kind : Byte         {0 = format beginning}
                                  {1 = formatting Track}
                                  {2 = verifying Track}
                                  {3 = writing boot and FAT}
                                  {4 = format ending, Track = format status}
              ) : Boolean;        {Return True to abort format}


procedure ResetDrive(Drive : DriveNumber);
  {-Reset drive system (function $00). Call after any other
    disk function fails}


function GetDiskStatus : Byte;
  {-Get status of last int $13 operation (function $01)}


function GetStatusStr(ErrNum : Byte) : String;
  {-Return message string for any of the status codes used by
    this unit.}


function GetDriveType(Drive : DriveNumber) : DriveType;
  {-Get drive type (function $08). Note that this returns the
    type of the *drive*, not the type of the diskette in it.
    GetDriveType returns 0 for an invalid drive.}


function AllocBuffer(var P : Pointer; Size : Word) : Boolean;
  {-Allocate a buffer useable in real and protected mode.
    Buffers passed to ReadSectors and WriteSectors in pmode
    *MUST* be allocated by using this function. AllocBuffer returns
    False if sufficient memory is not available. P is also set to
    nil in that case.}


procedure FreeBuffer(P : Pointer; Size : Word);
  {-Free buffer allocated by AllocBuffer. Size must match the
    size originally passed to AllocBuffer. FreeBuffer does
    nothing if P is nil.}


function ReadSectors(Drive : DriveNumber;
                     Track, Side, SSect, NSect : Byte;
                     var Buffer) : Byte;
  {-Read absolute disk sectors (function $02). Track, Side,
    and SSect specify the location of the first sector to
    read. NSect is the number of sectors to read. Buffer
    must be large enough to hold these sectors. ReadSectors
    returns a status code, 0 for success.}


function WriteSectors(Drive : DriveNumber;
                      Track, Side, SSect, NSect : Byte;
                      var Buffer) : Byte;
  {-Write absolute disk sectors (function $03). Track, Side,
    and SSect specify the location of the first sector to
    write. NSect is the number of sectors to write. Buffer
    must contain all the data to write. WriteSectors
    returns a status code, 0 for success.}


function VerifySectors(Drive : DriveNumber;
                       Track, Side, SSect, NSect : Byte) : Byte;
  {-Verify absolute disk sectors (function $04). This
    tests a computed CRC with the CRC stored along with the
    sector. Track, Side, and SSect specify the location of
    the first sector to verify. NSect is the number of
    sectors to verify. VerifySectors returns a status code,
    0 for success. Don't call VerifySectors on PC/XTs and
    PC/ATs with a BIOS from 1985. It will overwrite the
    stack.}


function FormatDisk(Drive : DriveNumber; DType : DriveType;
                    Verify : Boolean; MaxBadSects : Byte;
                    VLabel : VolumeStr;
                    FAF : FormatAbortFunc) : Byte;
  {-Format drive that contains a disk of type DType. If Verify
    is True, each track is verified after it is formatted.
    MaxBadSects specifies the number of sectors that can be
    bad before the format is halted. If VLabel is not an
    empty string, FormatDisk puts the BIOS-level volume
    label onto the diskette. It does *not* add a DOS-level
    volume label. FAF is a user function hook that can be
    used to display status during the format, and to abort
    the format if the user so chooses. Parameters passed to
    this function are described in FormatAbortFunc above.
    FormatDisk also writes a boot sector and empty File
    Allocation Tables for the disk. FormatDisk returns a
    status code, 0 for success.}


function EmptyAbortFunc(Track : Byte; MaxTrack : Byte; Kind : Byte) : Boolean;
  {-Do-nothing abort function for FormatDisk}

  {========================================================================}

implementation

uses
{$IFDEF DPMI}
  WinApi,
  Dos;
  {$DEFINE pmode}
{$ELSE}
{$IFDEF Windows}
  WinApi,
  WinDos;
  {$DEFINE pmode}
{$ELSE}
  Dos;
  {$UNDEF pmode}
{$ENDIF}
{$ENDIF}

{$IFDEF Windows}
type
  Registers = TRegisters;
  DateTime = TDateTime;
{$ENDIF}

type
  DiskRec =
    record
      SSZ : Byte;                 {Sector size}
      SPT : Byte;                 {Sectors/track}
      TPD : Byte;                 {Tracks/disk}
      SPF : Byte;                 {Sectors/FAT}
      DSC : Byte;                 {Directory sectors}
      FID : Byte;                 {Format id for FAT}
      BRD : array[0..13] of Byte; {Variable boot record data}
    end;
  DiskRecs = array[1..4] of DiskRec;
  SectorArray = array[0..511] of Byte;

const
  DData : DiskRecs =              {BRD starts at offset 13 of FAT}
  ((SSZ : $02; SPT : $09; TPD : $27; SPF : $02; DSC : $07; FID : $FD; {5.25" - 360K}
    BRD : ($02, $01, $00, $02, $70, $00, $D0, $02, $FD, $02, $00, $09, $00, $02)),
   (SSZ : $02; SPT : $0F; TPD : $4F; SPF : $07; DSC : $0E; FID : $F9; {5.25" - 1.2M}
    BRD : ($01, $01, $00, $02, $E0, $00, $60, $09, $F9, $07, $00, $0F, $00, $02)),
   (SSZ : $02; SPT : $09; TPD : $4F; SPF : $03; DSC : $07; FID : $F9; {3.50" - 720K}
    BRD : ($02, $01, $00, $02, $70, $00, $A0, $05, $F9, $03, $00, $09, $00, $02)),
   (SSZ : $02; SPT : $12; TPD : $4F; SPF : $09; DSC : $0E; FID : $F0; {3.50" - 1.44M}
    BRD : ($01, $01, $00, $02, $E0, $00, $40, $0B, $F0, $09, $00, $12, $00, $02)));

  BootRecord : SectorArray = {Standard boot program}
  ($EB, $34, $90, $41, $4D, $53, $54, $20, $33, $2E, $30, $00, $02, $01, $01, $00, $02, $E0, $00, $40, $0B, $F0, $09, $00,
   $12, $00, $02, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $12,
   $00, $00, $00, $00, $01, $00, $FA, $33, $C0, $8E, $D0, $BC, $00, $7C, $16, $07, $BB, $78, $00, $36, $C5, $37, $1E, $56,
   $16, $53, $BF, $2B, $7C, $B9, $0B, $00, $FC, $AC, $26, $80, $3D, $00, $74, $03, $26, $8A, $05, $AA, $8A, $C4, $E2, $F1,
   $06, $1F, $89, $47, $02, $C7, $07, $2B, $7C, $FB, $CD, $13, $72, $67, $A0, $10, $7C, $98, $F7, $26, $16, $7C, $03, $06,
   $1C, $7C, $03, $06, $0E, $7C, $A3, $3F, $7C, $A3, $37, $7C, $B8, $20, $00, $F7, $26, $11, $7C, $8B, $1E, $0B, $7C, $03,
   $C3, $48, $F7, $F3, $01, $06, $37, $7C, $BB, $00, $05, $A1, $3F, $7C, $E8, $9F, $00, $B8, $01, $02, $E8, $B3, $00, $72,
   $19, $8B, $FB, $B9, $0B, $00, $BE, $D6, $7D, $F3, $A6, $75, $0D, $8D, $7F, $20, $BE, $E1, $7D, $B9, $0B, $00, $F3, $A6,
   $74, $18, $BE, $77, $7D, $E8, $6A, $00, $32, $E4, $CD, $16, $5E, $1F, $8F, $04, $8F, $44, $02, $CD, $19, $BE, $C0, $7D,
   $EB, $EB, $A1, $1C, $05, $33, $D2, $F7, $36, $0B, $7C, $FE, $C0, $A2, $3C, $7C, $A1, $37, $7C, $A3, $3D, $7C, $BB, $00,
   $07, $A1, $37, $7C, $E8, $49, $00, $A1, $18, $7C, $2A, $06, $3B, $7C, $40, $38, $06, $3C, $7C, $73, $03, $A0, $3C, $7C,
   $50, $E8, $4E, $00, $58, $72, $C6, $28, $06, $3C, $7C, $74, $0C, $01, $06, $37, $7C, $F7, $26, $0B, $7C, $03, $D8, $EB,
   $D0, $8A, $2E, $15, $7C, $8A, $16, $FD, $7D, $8B, $1E, $3D, $7C, $EA, $00, $00, $70, $00, $AC, $0A, $C0, $74, $22, $B4,
   $0E, $BB, $07, $00, $CD, $10, $EB, $F2, $33, $D2, $F7, $36, $18, $7C, $FE, $C2, $88, $16, $3B, $7C, $33, $D2, $F7, $36,
   $1A, $7C, $88, $16, $2A, $7C, $A3, $39, $7C, $C3, $B4, $02, $8B, $16, $39, $7C, $B1, $06, $D2, $E6, $0A, $36, $3B, $7C,
   $8B, $CA, $86, $E9, $8A, $16, $FD, $7D, $8A, $36, $2A, $7C, $CD, $13, $C3, $0D, $0A, $4E, $6F, $6E, $2D, $53, $79, $73,
   $74, $65, $6D, $20, $64, $69, $73, $6B, $20, $6F, $72, $20, $64, $69, $73, $6B, $20, $65, $72, $72, $6F, $72, $0D, $0A,
   $52, $65, $70, $6C, $61, $63, $65, $20, $61, $6E, $64, $20, $73, $74, $72, $69, $6B, $65, $20, $61, $6E, $79, $20, $6B,
   $65, $79, $20, $77, $68, $65, $6E, $20, $72, $65, $61, $64, $79, $0D, $0A, $00, $0D, $0A, $44, $69, $73, $6B, $20, $42,
   $6F, $6F, $74, $20, $66, $61, $69, $6C, $75, $72, $65, $0D, $0A, $00, $49, $4F, $20, $20, $20, $20, $20, $20, $53, $59,
   $53, $4D, $53, $44, $4F, $53, $20, $20, $20, $53, $59, $53, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00,
   $00, $00, $00, $00, $00, $00, $55, $AA);

  MediaArray : array[DriveType, 1..2] of Byte =
    (($00, $00),     {Unknown disk}
     ($01, $02),     {360K disk}
     ($00, $03),     {1.2M disk}
     ($00, $04),     {720K disk}
     ($00, $04));    {1.44M disk}

{$IFDEF pmode}
type
  DPMIRegisters =
    record
      DI : LongInt;
      SI : LongInt;
      BP : LongInt;
      Reserved : LongInt;
      BX : LongInt;
      DX : LongInt;
      CX : LongInt;
      AX : LongInt;
      Flags : Word;
      ES : Word;
      DS : Word;
      FS : Word;
      GS : Word;
      IP : Word;
      CS : Word;
      SP : Word;
      SS : Word;
    end;

  function GetRealSelector(RealPtr : Pointer; Limit : Word) : Word;
    {-Set up a selector to point to RealPtr memory}
  type
    OS =
      record
        O, S : Word;
      end;
  var
    Status : Word;
    Selector : Word;
    Base : LongInt;
  begin
    GetRealSelector := 0;
    Selector := AllocSelector(0);
    if Selector = 0 then
      Exit;
    {Assure a read/write selector}
    Status := ChangeSelector(CSeg, Selector);
    Base := (LongInt(OS(RealPtr).S) shl 4)+LongInt(OS(RealPtr).O);
    if SetSelectorBase(Selector, Base) = 0 then begin
      Selector := FreeSelector(Selector);
      Exit;
    end;
    Status := SetSelectorLimit(Selector, Limit);
    GetRealSelector := Selector;
  end;

  procedure GetRealIntVec(IntNo : Byte; var Vector : Pointer); Assembler;
  asm
    mov     ax,0200h
    mov     bl,IntNo
    int     31h
    les     di,Vector
    mov     word ptr es:[di],dx
    mov     word ptr es:[di+2],cx
  end;

  function RealIntr(IntNo : Byte; var Regs : DPMIRegisters) : Word; Assembler;
  asm
    xor     bx,bx
    mov     bl,IntNo
    xor     cx,cx        {StackWords = 0}
    les     di,Regs
    mov     ax,0300h
    int     31h
    jc      @@ExitPoint
    xor     ax,ax
  @@ExitPoint:
  end;
{$ENDIF}

  procedure Int13Call(var Regs : Registers);
    {-Call int $13 for real or protected mode}
{$IFDEF pmode}
  var
    Base : LongInt;
    DRegs : DPMIRegisters;
{$ENDIF}
  begin
{$IFDEF pmode}
    {This pmode code is valid only for the AH values used in this unit}
    FillChar(DRegs, SizeOf(DPMIRegisters), 0);
    DRegs.AX := Regs.AX;
    DRegs.BX := Regs.BX;
    DRegs.CX := Regs.CX;
    DRegs.DX := Regs.DX;
    case Regs.AH of
      2, 3, 5 :
        {Calls that use ES as a buffer segment}
        begin
          Base := GetSelectorBase(Regs.ES);
          if (Base <= 0) or (Base > $FFFF0) then begin
            Regs.Flags := 1;
            Regs.AX := 1;
            Exit;
          end;
          DRegs.ES := Base shr 4;
        end;
    end;
    if RealIntr($13, DRegs) <> 0 then begin
      Regs.Flags := 1;
      Regs.AX := 1;
    end else begin
      Regs.Flags := DRegs.Flags;
      Regs.AX := DRegs.AX;
      Regs.BX := DRegs.BX; {BX is returned by GetDriveType function only}
    end;

{$ELSE}
    Intr($13, Regs);
{$ENDIF}
  end;

  function GetDriveType(Drive : DriveNumber) : DriveType;
  var
    Regs : Registers;
  begin
    Regs.AH := $08;
    Regs.DL := Drive;
    Int13Call(Regs);
    if Regs.AH = 0 then
      GetDriveType := Regs.BL
    else
      GetDriveType := 0;
  end;

  function GetDiskStatus : Byte;
  var
    Regs : Registers;
  begin
    Regs.AH := $01;
    Int13Call(Regs);
    GetDiskStatus := Regs.AL;
  end;

  function GetStatusStr(ErrNum : Byte) : String;
  var
    NumStr : string[3];
  begin
    case ErrNum of
      {Following codes are defined by the floppy BIOS}
      $00 : GetStatusStr := '';
      $01 : GetStatusStr := 'Invalid command';
      $02 : GetStatusStr := 'Address mark not found';
      $03 : GetStatusStr := 'Disk write protected';
      $04 : GetStatusStr := 'Sector not found';
      $06 : GetStatusStr := 'Floppy disk removed';
      $08 : GetStatusStr := 'DMA overrun';
      $09 : GetStatusStr := 'DMA crossed 64KB boundary';
      $0C : GetStatusStr := 'Media type not found';
      $10 : GetStatusStr := 'Uncorrectable CRC error';
      $20 : GetStatusStr := 'Controller failed';
      $40 : GetStatusStr := 'Seek failed';
      $80 : GetStatusStr := 'Disk timed out';

      {Following codes are added by this unit}
      $FA : GetStatusStr := 'Format aborted';
      $FB : GetStatusStr := 'Invalid media type';
      $FC : GetStatusStr := 'Too many bad sectors';
      $FD : GetStatusStr := 'Disk bad';
      $FE : GetStatusStr := 'Invalid drive or type';
      $FF : GetStatusStr := 'Insufficient memory';
    else
      Str(ErrNum, NumStr);
      GetStatusStr := 'Unknown error '+NumStr;
    end;
  end;

  procedure ResetDrive(Drive : DriveNumber);
  var
    Regs : Registers;
  begin
    Regs.AH := $00;
    Regs.DL := Drive;
    Int13Call(Regs);
  end;

  function AllocBuffer(var P : Pointer; Size : Word) : Boolean;
  var
    L : LongInt;
  begin
{$IFDEF pmode}
    L := GlobalDosAlloc(Size);
    if L <> 0 then begin
      P := Ptr(Word(L and $FFFF), 0);
      AllocBuffer := True;
    end else begin
      P := nil;
      AllocBuffer := False
    end;
{$ELSE}
    if MaxAvail >= Size then begin
      GetMem(P, Size);
      AllocBuffer := True;
    end else begin
      P := nil;
      AllocBuffer := False;
    end;
{$ENDIF}
  end;

  procedure FreeBuffer(P : Pointer; Size : Word);
  begin
    if P = nil then
      Exit;
{$IFDEF pmode}
    Size := GlobalDosFree(LongInt(P) shr 16);
{$ELSE}
    FreeMem(P, Size);
{$ENDIF}
  end;

  function CheckParms(DType : DriveType; Drive : DriveNumber) : Boolean;
    {-Make sure drive and type are within range}
  begin
    CheckParms := False;
    if (DType < 1) or (DType > 4) then
      Exit;
    if (Drive > 7) then
      Exit;
    CheckParms := True;
  end;

  function SubfSectors(SubFunc : Byte;
                       Drive : DriveNumber;
                       Track, Side, SSect, NSect : Byte;
                       var Buffer) : Byte;
    {-Code shared by ReadSectors, WriteSectors, VerifySectors, FormatTrack}
  var
    Tries : Byte;
    Done : Boolean;
    Regs : Registers;
  begin
    Tries := 1;
    Done := False;
    repeat
      Regs.AH := SubFunc;
      Regs.AL := NSect;
      Regs.CH := Track;
      Regs.CL := SSect;
      Regs.DH := Side;
      Regs.DL := Drive;
      Regs.ES := Seg(Buffer);
      Regs.BX := Ofs(Buffer);
      Int13Call(Regs);

      if Regs.AH <> 0 then begin
        ResetDrive(Drive);
        Inc(Tries);
        if Tries > MaxRetries then
          Done := True;
      end else
        Done := True;
    until Done;

    SubfSectors := Regs.AH;
  end;

  function ReadSectors(Drive : DriveNumber;
                       Track, Side, SSect, NSect : Byte;
                       var Buffer) : Byte;
  begin
    ReadSectors := SubfSectors($02, Drive, Track, Side, SSect, NSect, Buffer);
  end;

  function WriteSectors(Drive : DriveNumber;
                        Track, Side, SSect, NSect : Byte;
                        var Buffer) : Byte;
  begin
    WriteSectors := SubfSectors($03, Drive, Track, Side, SSect, NSect, Buffer);
  end;

  function VerifySectors(Drive : DriveNumber;
                         Track, Side, SSect, NSect : Byte) : Byte;
  var
    Dummy : Byte;
  begin
    VerifySectors := SubfSectors($04, Drive, Track, Side, SSect, NSect, Dummy);
  end;

  function SetDriveTable(DType : DriveType) : Boolean;
    {-Set drive table parameters for formatting}
  var
    P : Pointer;
    DBSeg : Word;
    DBOfs : Word;
  begin
    SetDriveTable := False;

{$IFDEF pmode}
    GetRealIntVec($1E, P);
    DBSeg := GetRealSelector(P, $FFFF);
    if DBSeg = 0 then
      Exit;
    DBOfs := 0;
{$ELSE}
    GetIntVec($1E, P);
    DBSeg := LongInt(P) shr 16;
    DBOfs := LongInt(P) and $FFFF;
{$ENDIF}

    {Set gap length for formatting}
    case DType of
      1 : Mem[DBSeg:DBOfs+7] := $50; {360K}
      2 : Mem[DBSeg:DBOfs+7] := $54; {1.2M}
      3,
      4 : Mem[DBSeg:DBOfs+7] := $6C; {720K or 1.44M}
    end;

    {Set max sectors/track}
    Mem[DBSeg:DBOfs+4] := DData[DType].SPT;

{$IFDEF pmode}
    DBSeg := FreeSelector(DBSeg);
{$ENDIF}

    SetDriveTable := True;
  end;

  function GetMachineID : Byte;
    {-Return machine ID code}
{$IFDEF pmode}
  var
    SegFFFF : Word;
{$ENDIF}
  begin
{$IFDEF pmode}
    SegFFFF := GetRealSelector(Ptr($FFFF, $0000), $FFFF);
    if SegFFFF = 0 then
      GetMachineID := 0
    else begin
      GetMachineID := Mem[SegFFFF:$000E];
      SegFFFF := FreeSelector(SegFFFF);
    end;
{$ELSE}
    GetMachineID := Mem[$FFFF:$000E];
{$ENDIF}
  end;

  function IsATMachine : Boolean;
    {-Return True if AT or better machine}
  begin
    IsATMachine := False;
    if Lo(DosVersion) >= 3 then
      case GetMachineId of
        $FC, $F8 :  {AT or PS/2}
          IsATMachine := True;
      end;
  end;

  function GetChangeLineType(Drive : DriveNumber; var CLT : Byte) : Byte;
    {-Return change line type of drive}
  var
    Regs : Registers;
  begin
    Regs.AH := $15;
    Regs.DL := Drive;
    Int13Call(Regs);
    if (Regs.Flags and FCarry) <> 0 then begin
      GetChangeLineType := Regs.AH;
      CLT := 0;
    end else begin
      GetChangeLineType := 0;
      CLT := Regs.AH;
    end;
  end;

  function SetFloppyType(Drive : DriveNumber; FType : Byte) : Byte;
    {-Set floppy type for formatting}
  var
    Tries : Byte;
    Done : Boolean;
    Regs : Registers;
  begin
    Tries := 1;
    Done := False;
    repeat
      Regs.AH := $17;
      Regs.AL := FType;
      Regs.DL := Drive;
      Int13Call(Regs);
      if Regs.AH <> 0 then begin
        ResetDrive(Drive);
        Inc(Tries);
        if Tries > MaxRetries then
          Done := True;
      end else
        Done := True;
    until Done;

    SetFloppyType := Regs.AH;
  end;

  function SetMediaType(Drive : DriveType; TPD : Byte; SPT : Byte) : Byte;
    {-Set media type for formatting}
  var
    Regs : Registers;
  begin
    Regs.AH := $18;
    Regs.DL := Drive;
    Regs.CH := TPD;
    Regs.CL := SPT;
    Int13Call(Regs);
    SetMediaType := Regs.AH;
  end;

  function FormatDisk(Drive : DriveNumber; DType : DriveType;
                      Verify : Boolean; MaxBadSects : Byte;
                      VLabel : VolumeStr;
                      FAF : FormatAbortFunc) : Byte;
  label
    ExitPoint;
  type
    CHRNRec =
      record
        CTrack : Byte;            {Track  0..?}
        CSide : Byte;             {Side   0..1}
        CSect : Byte;             {Sector 1..?}
        CSize : Byte;             {Size   0..?}
      end;
    CHRNArray = array[1..18] of CHRNRec;
    FATArray = array[0..4607] of Byte;
  var
    Tries : Byte;
    Track : Byte;
    Side : Byte;
    Sector : Byte;
    RWritten : Byte;
    RTotal : Byte;
    FatNum : Byte;
    BadSects : Byte;
    ChangeLine : Byte;
    DiskType : Byte;
    Status : Byte;
    Done : Boolean;
    Trash : Word;
    DT : DateTime;
    VDate : LongInt;
    Regs : Registers;
    BootPtr : ^SectorArray;
    CHRN : ^CHRNArray;
    FATs : ^FATArray;

    procedure MarkBadSector(Track, Side, Sector : Byte);
    const
      BadMark = $FF7;             {Bad cluster mark}
    var
      CNum : Integer;             {Cluster number}
      FOfs : Word;                {Offset into fat for this cluster}
      FVal : Word;                {FAT value for this cluster}
      OFVal : Word;               {Old FAT value for this cluster}
    begin
      CNum := (((((Track*2)+Side)*DData[DType].SPT)+Sector-RTotal-2) div
              DData[DType].BRD[0])+2;
      if CNum > 1 then begin
        {Sector is in data space}
        FOfs := (CNum*3) div 2;
        Move(FATs^[FOfs], FVal, 2);
        if Odd(CNum) then
          OFVal := (FVal and (BadMark shl 4))
        else
          OFVal := (FVal and BadMark);
        if OFVal = 0 then begin
          {Not already marked bad, mark it}
          if Odd(CNum) then
            FVal := (FVal or (BadMark shl 4))
          else
            FVal := (FVal or BadMark);
          Move(FVal, FATs^[FOfs], 2);
          {Add to bad sector count}
          Inc(BadSects, DData[DType].BRD[0]);
        end;
      end;
    end;

  begin
    {Validate parameters. Can't do anything unless these are reasonable}
    if not CheckParms(DType, Drive) then
      Exit;

    {Initialize buffer pointers in case of failure}
    FATs := nil;
    CHRN := nil;
    BootPtr := nil;

    {Status proc: starting format}
    if FAF(0, DData[DType].TPD, 0) then begin
      Status := $FA;
      goto ExitPoint;
    end;

    {Error code for invalid drive or media type}
    Status := $FE;

    case GetDriveType(Drive) of
      1 : {360K drive formats only 360K disks}
        if DType <> 1 then
          goto ExitPoint;
      2 : {1.2M drive formats 360K or 1.2M disk}
        if DType > 2 then
          goto ExitPoint;
      3 : {720K drive formats only 720K disks}
        if DType <> 3 then
          goto ExitPoint;
      4 : {1.44M drive formats 720K or 1.44M disks}
        if Dtype < 3 then
          goto ExitPoint;
    else
      goto ExitPoint;
    end;

    {Error code for out-of-memory or DPMI error}
    Status := $FF;

    {Allocate buffers}
    if not AllocBuffer(Pointer(FATs), SizeOf(FATArray)) then
      goto ExitPoint;
    if not AllocBuffer(Pointer(CHRN), SizeOf(CHRNArray)) then
      goto ExitPoint;
    if not AllocBuffer(Pointer(BootPtr), SizeOf(BootRecord)) then
      goto ExitPoint;

    {Initialize boot record}
    Move(BootRecord, BootPtr^, SizeOf(BootRecord));
    Move(DData[DType].BRD, BootPtr^[13], 14);

    {Initialize the FAT table}
    FillChar(FATs^, SizeOf(FATArray), 0);
    FATs^[0] := DData[DType].FID;
    FATs^[1] := $FF;
    FATs^[2] := $FF;

    {Set drive table parameters by patching drive table in memory}
    if not SetDriveTable(DType) then
      goto ExitPoint;

    {On AT class machines, set format parameters via BIOS}
    if IsATMachine then begin
      {Get change line type: 1 -> 360K drive, 2 -> 1.2M or 3.5" drive}
      Status := GetChangeLineType(Drive, ChangeLine);
      if Status <> 0 then
        goto ExitPoint;
      if (ChangeLine < 1) or (ChangeLine > 2) then begin
        Status := 1;
        goto ExitPoint;
      end;

      {Determine floppy type for SetFloppyType call}
      DiskType := MediaArray[DType, ChangeLine];
      if DiskType = 0 then begin
        Status := $FB;
        goto ExitPoint;
      end;

      {Set floppy type for drive}
      Status := SetFloppyType(Drive, DiskType);
      if Status <> 0 then
        goto ExitPoint;

      {Set media type for format}
      Status := SetMediaType(Drive, DData[DType].TPD, DData[DType].SPT);
      if Status <> 0 then
        goto ExitPoint;
    end;

    {Format each sector}
    ResetDrive(Drive);
    BadSects := 0;

    for Track := 0 to DData[DType].TPD do begin
      {Status proc: formatting track}
      if FAF(Track, DData[DType].TPD, 1) then begin
        Status := $FA;
        goto ExitPoint;
      end;

      for Side := 0 to 1 do begin
        {Initialize CHRN for this sector}
        for Sector := 1 to DData[DType].SPT do
          with CHRN^[Sector] do begin
            CTrack := Track;
            CSide := Side;
            CSect := Sector;
            CSize := DData[DType].SSZ;
          end;

        {Format this sector, with retries}
        Status := SubfSectors($05, Drive, Track, Side,
                              1, DData[DType].SPT, CHRN^);
        if Status <> 0 then
          goto ExitPoint;
      end;

      if Verify then begin
        {Status proc: verifying track}
        if FAF(Track, DData[DType].TPD, 2) then begin
          Status := $FA;
          goto ExitPoint;
        end;

        for Side := 0 to 1 do
          {Verify the entire track}
          if VerifySectors(Drive, Track, Side,
                           1, DData[DType].SPT) <> 0 then begin
            if Track = 0 then begin
              {Disk bad}
              Status := $FD;
              goto ExitPoint;
            end;

            for Sector := 1 to DData[DType].SPT do
              if VerifySectors(Drive, Track, Side,
                               Sector, 1) <> 0 then begin
                MarkBadSector(Track, Side, Sector);
                if BadSects > MaxBadSects then begin
                  Status := $FC;
                  goto ExitPoint;
                end;
              end;
          end;
      end;
    end;

    {Status proc: writing boot and FAT}
    if FAF(0, DData[DType].TPD, 3) then begin
      Status := $FA;
      goto ExitPoint;
    end;

    {Write boot record}
    Status := WriteSectors(Drive, 0, 0, 1, 1, BootPtr^);
    if Status <> 0 then begin
      Status := $FD;
      goto ExitPoint;
    end;

    {Write FATs and volume label}
    Track := 0;
    Side := 0;
    Sector := 2;
    FatNum := 0;
    RTotal := (2*DData[DType].SPF)+DData[DType].DSC;
    for RWritten := 0 to RTotal-1 do begin
      if Sector > DData[DType].SPT then begin
        Sector := 1;
        Inc(Side);
      end;

      if RWritten < (2*DData[DType].SPF) then begin
        if FatNum > DData[DType].SPF-1 then
          FatNum := 0;
      end else begin
        FillChar(FATs^, 512, 0);
        if ((VLabel <> '') and (RWritten = 2*DData[DType].SPF)) then begin
          {Put in volume label}
          for Trash := 1 to Length(VLabel) do
            VLabel[Trash] := Upcase(VLabel[Trash]);
          while Length(VLabel) < 11 do
            VLabel := VLabel+' ';
          Move(VLabel[1], FATs^, 11);
          FATs^[11] := 8;
          GetDate(DT.Year, DT.Month, DT.Day, Trash);
          GetTime(DT.Hour, DT.Min, DT.Sec, Trash);
          PackTime(DT, VDate);
          Move(VDate, FATs^[22], 4);
        end;
        FatNum := 0;
      end;

      if WriteSectors(Drive, Track, Side,
                      Sector, 1, FATs^[FatNum*512]) <> 0 then begin
        Status := $FD;
        goto ExitPoint;
      end;

      Inc(Sector);
      Inc(FatNum);
    end;

    {Success}
    Status := 0;

ExitPoint:
    FreeBuffer(BootPtr, SizeOf(BootRecord));
    FreeBuffer(CHRN, SizeOf(CHRNArray));
    FreeBuffer(FATs, SizeOf(FATArray));

    {Status proc: ending format}
    Done := FAF(Status, DData[DType].TPD, 4);
    FormatDisk := Status;
  end;

  function EmptyAbortFunc(Track, MaxTrack : Byte; Kind : Byte) : Boolean;
  begin
    EmptyAbortFunc := False;
  end;

end.

{ -------------------------------    DEMO PROGRAM   -------------------- }
{ -------------------------------     CUT HERE      ---------------------}

{$R-,S-,I-}

program Fmt;
  {-Simple formatting program to demonstate DISKB unit}

uses
{$IFDEF Windows}
  WinCrt,
{$ENDIF}
  BDisk;

const
  ESC = #27;
  CR = #13;

type
  CharSet = set of Char;

var
  DLet : Char;
  DTyp : Char;
  Verf : Char;
  GLet : Char;
  DNum : Byte;
  Status : Byte;
  VStr : VolumeStr;

const
  DriveTypeName : array[DriveType] of string[5] =
    ('other', '360K', '1.2M', '720K', '1.44M');

{$IFNDEF Windows}
  function ReadKey : Char; assembler;
    {-Low budget readkey routine}
  asm
    xor ah,ah
    int 16h
  end;
{$ENDIF}

  function GetKey(Prompt : String; OKSet : CharSet) : Char;
    {-Get and return a key in the OKSet}
  var
    Ch : Char;
  begin
    Write(Prompt);
    repeat
      Ch := Upcase(ReadKey);
      if Ch = ESC then begin
        WriteLn;
        Halt;
      end;
    until (Ch in OKSet);
    if Ch <> CR then
      Write(Ch);
    WriteLn;
    GetKey := Ch;
  end;

  function AbortFunc(Track, MaxTrack : Byte; Kind : Byte) : Boolean; far;
    {-Display formatting status. Could check for abort here too}
  begin
    case Kind of
      0 : {Format beginning}
        Write('Formatting     ');
      1 : {Formatting track}
        Write(^H^H^H^H, ((Track*100) div MaxTrack):3, '%');
      2 : {Verifying track}
        Write(^H, 'V');
      3 : {Writing boot and FAT}
        Write(^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H, 'Writing boot and FAT');
      4 : {Format ending}
        begin
          Write(^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H);
          {Track returns final status code in this case}
          if Track = 0 then
            WriteLn('Formatted successfully')
          else
            WriteLn('Format failed: ', GetStatusStr(Track));
        end;
    end;
    AbortFunc := False;
  end;

begin
  WriteLn('Floppy Formatter: <Esc> to exit');

  {Get formatting parameters}
  DLet := GetKey('Drive to format? (A or B): ', ['A'..'B']);
  DTyp := GetKey('Disk type? (1=360K, 2=1.2M, 3=720K, 4=1.44M): ', ['1'..'4']);
  Verf := GetKey('Verify? (Y or N) ', ['N', 'Y']);
  Write('Volume label? ');
  ReadLn(VStr);
  GLet := GetKey('Insert disk and press <Enter> ', [#13]);

  {Compute drive number}
  DNum := Byte(DLet)-Byte('A');

  WriteLn('Drive type is ', DriveTypeName[GetDriveType(DNum)]);

  Status := FormatDisk(DNum,                    {drive number}
                       Byte(DTyp)-Byte('0'),    {format type}
                       (Verf = 'Y'),            {verify?}
                       10,                      {max bad sectors}
                       VStr,                    {volume label}
                       AbortFunc);              {abort function}
  {AbortFunc reports the status}
end.