home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 April A / Pcwk4a98.iso / PROGRAM / DELPHI16 / Format / BDISK.PAS < prev    next >
Pascal/Delphi Source File  |  1995-05-24  |  30KB  |  970 lines
  1. {$R-,S-,I-,B-,F-}
  2. {$IFNDEF Windows}
  3.   {$O+}
  4. {$ENDIF}
  5.  
  6. {---------------------------------------------------------
  7.  BIOS disk I/O routines for floppy drives. Supports DOS
  8.  real mode, DOS protected mode, and Windows. Requires
  9.  TP6, TPW, BP7, or Delphi.
  10.  
  11.  All functions are for floppy disks only; no hard drives.
  12.  
  13.  See the individual types and functions in the interface of
  14.  this unit for more information. See the FORMAT.DPR Delphi project sample
  15.  program for an example of formatting disks.
  16.  
  17.  For status code definitions, see the implementation of
  18.  function GetStatusStr.
  19.  
  20.  ---------------------------------------------------------
  21.  Based on a unit provided by Henning Jorgensen of Denmark.
  22.  Modified and cleaned up by TurboPower Software for pmode
  23.  and Windows operation.
  24.  
  25.  TurboPower Software
  26.  P.O. Box 49009
  27.  Colorado Springs, CO 80949-9009
  28.  
  29.  CompuServe: 76004,2611
  30.  
  31.  Version 1.0  10/25/93
  32.  Version 1.1  10/29/93
  33.    fix a dumb bug in the MediaArray check
  34.  Version 1.2  12/02/93
  35.    make it compile with TPW 1.5
  36.    fix bug in MarkBadSector
  37.    if MaxBadSects passed to FormatDisk is 0, no limit
  38.      is set on maximum bad sectors (emulates DOS FORMAT)
  39.    check more carefully before saying "Disk Bad"
  40.    reduce automatic retries while marking bad sectors
  41.    change boot sector ID string to 'BDISK1.2'
  42.  ---------------------------------------------------------}
  43.  
  44. unit BDisk;
  45.   {-BIOS disk I/O routines for floppy drives}
  46.  
  47. interface
  48.  
  49. const
  50.   MaxRetries : Byte = 3;          {Number of automatic retries for
  51.                                    read, write, verify, format}
  52.  
  53. type
  54.   DriveNumber = 0..7;             {Acceptable floppy drive numbers}
  55.                                   {Generally, 0 = A, 1 = B}
  56.  
  57.   DriveType = 0..4;               {Floppy drive or disk types}
  58.                                   {0 = unknown or error
  59.                                    1 = 360K
  60.                                    2 = 1.2M
  61.                                    3 = 720K
  62.                                    4 = 1.44M}
  63.  
  64.   VolumeStr = String[11];         {String for volume labels}
  65.  
  66.   FormatAbortFunc =               {Prototype for format abort func}
  67.     function (Track : Byte;       {Track number being formatted, 0..MaxTrack}
  68.               MaxTrack : Byte;    {Maximum track number for this format}
  69.               Kind : Byte         {0 = format beginning}
  70.                                   {1 = formatting Track}
  71.                                   {2 = verifying Track}
  72.                                   {3 = writing boot and FAT}
  73.                                   {4 = format ending, Track = format status}
  74.               ) : Boolean;        {Return True to abort format}
  75.  
  76.  
  77. procedure ResetDrive(Drive : DriveNumber);
  78.   {-Reset drive system (function $00). Call after any other
  79.     disk function fails}
  80.  
  81.  
  82. function GetDiskStatus : Byte;
  83.   {-Get status of last int $13 operation (function $01)}
  84.  
  85.  
  86. function GetStatusStr(ErrNum : Byte) : String;
  87.   {-Return message string for any of the status codes used by
  88.     this unit.}
  89.  
  90.  
  91. function GetDriveType(Drive : DriveNumber) : DriveType;
  92.   {-Get drive type (function $08). Note that this returns the
  93.     type of the *drive*, not the type of the diskette in it.
  94.     GetDriveType returns 0 for an invalid drive.}
  95.  
  96.  
  97. function AllocBuffer(var P : Pointer; Size : Word) : Boolean;
  98.   {-Allocate a buffer useable in real and protected mode.
  99.     Buffers passed to ReadSectors and WriteSectors in pmode
  100.     *MUST* be allocated by using this function. AllocBuffer returns
  101.     False if sufficient memory is not available. P is also set to
  102.     nil in that case.}
  103.  
  104.  
  105. procedure FreeBuffer(P : Pointer; Size : Word);
  106.   {-Free buffer allocated by AllocBuffer. Size must match the
  107.     size originally passed to AllocBuffer. FreeBuffer does
  108.     nothing if P is nil.}
  109.  
  110.  
  111. function ReadSectors(Drive : DriveNumber;
  112.                      Track, Side, SSect, NSect : Byte;
  113.                      var Buffer) : Byte;
  114.   {-Read absolute disk sectors (function $02). Track, Side,
  115.     and SSect specify the location of the first sector to
  116.     read. NSect is the number of sectors to read. Buffer
  117.     must be large enough to hold these sectors. ReadSectors
  118.     returns a status code, 0 for success.}
  119.  
  120.  
  121. function WriteSectors(Drive : DriveNumber;
  122.                       Track, Side, SSect, NSect : Byte;
  123.                       var Buffer) : Byte;
  124.   {-Write absolute disk sectors (function $03). Track, Side,
  125.     and SSect specify the location of the first sector to
  126.     write. NSect is the number of sectors to write. Buffer
  127.     must contain all the data to write. WriteSectors
  128.     returns a status code, 0 for success.}
  129.  
  130.  
  131. function VerifySectors(Drive : DriveNumber;
  132.                        Track, Side, SSect, NSect : Byte) : Byte;
  133.   {-Verify absolute disk sectors (function $04). This
  134.     tests a computed CRC with the CRC stored along with the
  135.     sector. Track, Side, and SSect specify the location of
  136.     the first sector to verify. NSect is the number of
  137.     sectors to verify. VerifySectors returns a status code,
  138.     0 for success. Don't call VerifySectors on PC/XTs and
  139.     PC/ATs with a BIOS from 1985. It will overwrite the
  140.     stack.}
  141.  
  142.  
  143. function FormatDisk(Drive : DriveNumber; DType : DriveType;
  144.                     Verify : Boolean; MaxBadSects : Byte;
  145.                     VLabel : VolumeStr;
  146.                     FAF : FormatAbortFunc) : Byte;
  147.   {-Format drive that contains a disk of type DType. If Verify
  148.     is True, each track is verified after it is formatted.
  149.     MaxBadSects specifies the number of sectors that can be
  150.     bad before the format is halted. If VLabel is not an
  151.     empty string, FormatDisk puts the BIOS-level volume
  152.     label onto the diskette. It does *not* add a DOS-level
  153.     volume label. FAF is a user function hook that can be
  154.     used to display status during the format, and to abort
  155.     the format if the user so chooses. Parameters passed to
  156.     this function are described in FormatAbortFunc above.
  157.     FormatDisk also writes a boot sector and empty File
  158.     Allocation Tables for the disk. FormatDisk returns a
  159.     status code, 0 for success.}
  160.  
  161.  
  162. function EmptyAbortFunc(Track : Byte; MaxTrack : Byte; Kind : Byte) : Boolean;
  163.   {-Do-nothing abort function for FormatDisk}
  164.  
  165.   {========================================================================}
  166.  
  167. implementation
  168.  
  169. uses
  170. {$IFDEF DPMI}
  171.   WinApi,
  172.   Dos;
  173.   {$DEFINE pmode}
  174. {$ELSE}
  175. {$IFDEF Windows}
  176. {$IFDEF Ver70}
  177.   WinApi,
  178. {$ELSE}
  179.   WinTypes,
  180.   WinProcs,
  181. {$ENDIF}
  182.   WinDos;
  183.   {$DEFINE pmode}
  184. {$ELSE}
  185.   Dos;
  186.   {$UNDEF pmode}
  187. {$ENDIF}
  188. {$ENDIF}
  189.  
  190. {$IFDEF Windows}
  191. type
  192.   Registers = TRegisters;
  193.   DateTime = TDateTime;
  194. {$ENDIF}
  195.  
  196. type
  197.   DiskRec =
  198.     record
  199.       SSZ : Byte;                 {Sector size}
  200.       SPT : Byte;                 {Sectors/track}
  201.       TPD : Byte;                 {Tracks/disk}
  202.       SPF : Byte;                 {Sectors/FAT}
  203.       DSC : Byte;                 {Directory sectors}
  204.       FID : Byte;                 {Format id for FAT}
  205.       BRD : array[0..13] of Byte; {Variable boot record data}
  206.     end;
  207.   DiskRecs = array[1..4] of DiskRec;
  208.   SectorArray = array[0..511] of Byte;
  209.  
  210. const
  211.   DData : DiskRecs =              {BRD starts at offset 13 of FAT}
  212.   ((SSZ : $02; SPT : $09; TPD : $27; SPF : $02; DSC : $07; FID : $FD; {5.25" - 360K}
  213.     BRD : ($02, $01, $00, $02, $70, $00, $D0, $02, $FD, $02, $00, $09, $00, $02)),
  214.    (SSZ : $02; SPT : $0F; TPD : $4F; SPF : $07; DSC : $0E; FID : $F9; {5.25" - 1.2M}
  215.     BRD : ($01, $01, $00, $02, $E0, $00, $60, $09, $F9, $07, $00, $0F, $00, $02)),
  216.    (SSZ : $02; SPT : $09; TPD : $4F; SPF : $03; DSC : $07; FID : $F9; {3.50" - 720K}
  217.     BRD : ($02, $01, $00, $02, $70, $00, $A0, $05, $F9, $03, $00, $09, $00, $02)),
  218.    (SSZ : $02; SPT : $12; TPD : $4F; SPF : $09; DSC : $0E; FID : $F0; {3.50" - 1.44M}
  219.     BRD : ($01, $01, $00, $02, $E0, $00, $40, $0B, $F0, $09, $00, $12, $00, $02)));
  220.  
  221.   BootRecord : SectorArray = {Standard boot program}
  222.   ($EB, $34, $90,
  223.    {'BDISK1.2'}
  224.    $42, $44, $49, $53, $4B, $31, $2E, $32,
  225.  
  226.    $00, $02, $01, $01, $00, $02, $E0, $00, $40, $0B, $F0, $09, $00,
  227.    $12, $00, $02, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $12,
  228.    $00, $00, $00, $00, $01, $00, $FA, $33, $C0, $8E, $D0, $BC, $00, $7C, $16, $07, $BB, $78, $00, $36, $C5, $37, $1E, $56,
  229.    $16, $53, $BF, $2B, $7C, $B9, $0B, $00, $FC, $AC, $26, $80, $3D, $00, $74, $03, $26, $8A, $05, $AA, $8A, $C4, $E2, $F1,
  230.    $06, $1F, $89, $47, $02, $C7, $07, $2B, $7C, $FB, $CD, $13, $72, $67, $A0, $10, $7C, $98, $F7, $26, $16, $7C, $03, $06,
  231.    $1C, $7C, $03, $06, $0E, $7C, $A3, $3F, $7C, $A3, $37, $7C, $B8, $20, $00, $F7, $26, $11, $7C, $8B, $1E, $0B, $7C, $03,
  232.    $C3, $48, $F7, $F3, $01, $06, $37, $7C, $BB, $00, $05, $A1, $3F, $7C, $E8, $9F, $00, $B8, $01, $02, $E8, $B3, $00, $72,
  233.    $19, $8B, $FB, $B9, $0B, $00, $BE, $D6, $7D, $F3, $A6, $75, $0D, $8D, $7F, $20, $BE, $E1, $7D, $B9, $0B, $00, $F3, $A6,
  234.    $74, $18, $BE, $77, $7D, $E8, $6A, $00, $32, $E4, $CD, $16, $5E, $1F, $8F, $04, $8F, $44, $02, $CD, $19, $BE, $C0, $7D,
  235.    $EB, $EB, $A1, $1C, $05, $33, $D2, $F7, $36, $0B, $7C, $FE, $C0, $A2, $3C, $7C, $A1, $37, $7C, $A3, $3D, $7C, $BB, $00,
  236.    $07, $A1, $37, $7C, $E8, $49, $00, $A1, $18, $7C, $2A, $06, $3B, $7C, $40, $38, $06, $3C, $7C, $73, $03, $A0, $3C, $7C,
  237.    $50, $E8, $4E, $00, $58, $72, $C6, $28, $06, $3C, $7C, $74, $0C, $01, $06, $37, $7C, $F7, $26, $0B, $7C, $03, $D8, $EB,
  238.    $D0, $8A, $2E, $15, $7C, $8A, $16, $FD, $7D, $8B, $1E, $3D, $7C, $EA, $00, $00, $70, $00, $AC, $0A, $C0, $74, $22, $B4,
  239.    $0E, $BB, $07, $00, $CD, $10, $EB, $F2, $33, $D2, $F7, $36, $18, $7C, $FE, $C2, $88, $16, $3B, $7C, $33, $D2, $F7, $36,
  240.    $1A, $7C, $88, $16, $2A, $7C, $A3, $39, $7C, $C3, $B4, $02, $8B, $16, $39, $7C, $B1, $06, $D2, $E6, $0A, $36, $3B, $7C,
  241.    $8B, $CA, $86, $E9, $8A, $16, $FD, $7D, $8A, $36, $2A, $7C, $CD, $13, $C3, $0D, $0A, $4E, $6F, $6E, $2D, $53, $79, $73,
  242.    $74, $65, $6D, $20, $64, $69, $73, $6B, $20, $6F, $72, $20, $64, $69, $73, $6B, $20, $65, $72, $72, $6F, $72, $0D, $0A,
  243.    $52, $65, $70, $6C, $61, $63, $65, $20, $61, $6E, $64, $20, $73, $74, $72, $69, $6B, $65, $20, $61, $6E, $79, $20, $6B,
  244.    $65, $79, $20, $77, $68, $65, $6E, $20, $72, $65, $61, $64, $79, $0D, $0A, $00, $0D, $0A, $44, $69, $73, $6B, $20, $42,
  245.    $6F, $6F, $74, $20, $66, $61, $69, $6C, $75, $72, $65, $0D, $0A, $00, $49, $4F, $20, $20, $20, $20, $20, $20, $53, $59,
  246.    $53, $4D, $53, $44, $4F, $53, $20, $20, $20, $53, $59, $53, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00,
  247.    $00, $00, $00, $00, $00, $00, $55, $AA);
  248.  
  249.   MediaArray : array[DriveType, 1..2] of Byte =
  250.     (($00, $00),     {Unknown disk}
  251.      ($01, $02),     {360K disk}
  252.      ($00, $03),     {1.2M disk}
  253.      ($00, $04),     {720K disk}
  254.      ($00, $04));    {1.44M disk}
  255.  
  256. {$IFDEF pmode}
  257. type
  258.   DPMIRegisters =
  259.     record
  260.       DI : LongInt;
  261.       SI : LongInt;
  262.       BP : LongInt;
  263.       Reserved : LongInt;
  264.       BX : LongInt;
  265.       DX : LongInt;
  266.       CX : LongInt;
  267.       AX : LongInt;
  268.       Flags : Word;
  269.       ES : Word;
  270.       DS : Word;
  271.       FS : Word;
  272.       GS : Word;
  273.       IP : Word;
  274.       CS : Word;
  275.       SP : Word;
  276.       SS : Word;
  277.     end;
  278.  
  279.   function GetRealSelector(RealPtr : Pointer; Limit : Word) : Word;
  280.     {-Set up a selector to point to RealPtr memory}
  281.   type
  282.     OS =
  283.       record
  284.         O, S : Word;
  285.       end;
  286.   var
  287.     Status : Word;
  288.     Selector : Word;
  289.     Base : LongInt;
  290.   begin
  291.     GetRealSelector := 0;
  292.     Selector := AllocSelector(0);
  293.     if Selector = 0 then
  294.       Exit;
  295.     {Assure a read/write selector}
  296.     Status := ChangeSelector(CSeg, Selector);
  297.     Base := (LongInt(OS(RealPtr).S) shl 4)+LongInt(OS(RealPtr).O);
  298.     if SetSelectorBase(Selector, Base) = 0 then begin
  299.       Selector := FreeSelector(Selector);
  300.       Exit;
  301.     end;
  302.     Status := SetSelectorLimit(Selector, Limit);
  303.     GetRealSelector := Selector;
  304.   end;
  305.  
  306.   procedure GetRealIntVec(IntNo : Byte; var Vector : Pointer); Assembler;
  307.   asm
  308.     mov     ax,0200h
  309.     mov     bl,IntNo
  310.     int     31h
  311.     les     di,Vector
  312.     mov     word ptr es:[di],dx
  313.     mov     word ptr es:[di+2],cx
  314.   end;
  315.  
  316.   function RealIntr(IntNo : Byte; var Regs : DPMIRegisters) : Word; Assembler;
  317.   asm
  318.     xor     bx,bx
  319.     mov     bl,IntNo
  320.     xor     cx,cx        {StackWords = 0}
  321.     les     di,Regs
  322.     mov     ax,0300h
  323.     int     31h
  324.     jc      @@ExitPoint
  325.     xor     ax,ax
  326.   @@ExitPoint:
  327.   end;
  328. {$ENDIF}
  329.  
  330.   procedure Int13Call(var Regs : Registers);
  331.     {-Call int $13 for real or protected mode}
  332. {$IFDEF pmode}
  333.   var
  334.     Base : LongInt;
  335.     DRegs : DPMIRegisters;
  336. {$ENDIF}
  337.   begin
  338. {$IFDEF pmode}
  339.     {This pmode code is valid only for the AH values used in this unit}
  340.     FillChar(DRegs, SizeOf(DPMIRegisters), 0);
  341.     DRegs.AX := Regs.AX;
  342.     DRegs.BX := Regs.BX;
  343.     DRegs.CX := Regs.CX;
  344.     DRegs.DX := Regs.DX;
  345.     case Regs.AH of
  346.       2, 3, 5 :
  347.         {Calls that use ES as a buffer segment}
  348.         begin
  349.           Base := GetSelectorBase(Regs.ES);
  350.           if (Base <= 0) or (Base > $FFFF0) then begin
  351.             Regs.Flags := 1;
  352.             Regs.AX := 1;
  353.             Exit;
  354.           end;
  355.           DRegs.ES := Base shr 4;
  356.         end;
  357.     end;
  358.     if RealIntr($13, DRegs) <> 0 then begin
  359.       Regs.Flags := 1;
  360.       Regs.AX := 1;
  361.     end else begin
  362.       Regs.Flags := DRegs.Flags;
  363.       Regs.AX := DRegs.AX;
  364.       Regs.BX := DRegs.BX; {BX is returned by GetDriveType function only}
  365.     end;
  366.  
  367. {$ELSE}
  368.     Intr($13, Regs);
  369. {$ENDIF}
  370.   end;
  371.  
  372.   function GetDriveType(Drive : DriveNumber) : DriveType;
  373.   var
  374.     Regs : Registers;
  375.   begin
  376.     Regs.AH := $08;
  377.     Regs.DL := Drive;
  378.     Int13Call(Regs);
  379.     if Regs.AH = 0 then
  380.       GetDriveType := Regs.BL
  381.     else
  382.       GetDriveType := 0;
  383.   end;
  384.  
  385.   function GetDiskStatus : Byte;
  386.   var
  387.     Regs : Registers;
  388.   begin
  389.     Regs.AH := $01;
  390.     Int13Call(Regs);
  391.     GetDiskStatus := Regs.AL;
  392.   end;
  393.  
  394.   function GetStatusStr(ErrNum : Byte) : String;
  395.   var
  396.     NumStr : string[3];
  397.   begin
  398.     case ErrNum of
  399.       {Following codes are defined by the floppy BIOS}
  400.       $00 : GetStatusStr := '';
  401.       $01 : GetStatusStr := 'Invalid command';
  402.       $02 : GetStatusStr := 'Address mark not found';
  403.       $03 : GetStatusStr := 'Disk write protected';
  404.       $04 : GetStatusStr := 'Sector not found';
  405.       $06 : GetStatusStr := 'Floppy disk removed';
  406.       $08 : GetStatusStr := 'DMA overrun';
  407.       $09 : GetStatusStr := 'DMA crossed 64KB boundary';
  408.       $0C : GetStatusStr := 'Media type not found';
  409.       $10 : GetStatusStr := 'Uncorrectable CRC error';
  410.       $20 : GetStatusStr := 'Controller failed';
  411.       $40 : GetStatusStr := 'Seek failed';
  412.       $80 : GetStatusStr := 'Disk timed out';
  413.  
  414.       {Following codes are added by this unit}
  415.       $FA : GetStatusStr := 'Format aborted';
  416.       $FB : GetStatusStr := 'Invalid media type';
  417.       $FC : GetStatusStr := 'Too many bad sectors';
  418.       $FD : GetStatusStr := 'Disk bad';
  419.       $FE : GetStatusStr := 'Invalid drive or type';
  420.       $FF : GetStatusStr := 'Insufficient memory';
  421.     else
  422.       Str(ErrNum, NumStr);
  423.       GetStatusStr := 'Unknown error '+NumStr;
  424.     end;
  425.   end;
  426.  
  427.   procedure ResetDrive(Drive : DriveNumber);
  428.   var
  429.     Regs : Registers;
  430.   begin
  431.     Regs.AH := $00;
  432.     Regs.DL := Drive;
  433.     Int13Call(Regs);
  434.   end;
  435.  
  436.   function AllocBuffer(var P : Pointer; Size : Word) : Boolean;
  437.   var
  438.     L : LongInt;
  439.   begin
  440. {$IFDEF pmode}
  441.     L := GlobalDosAlloc(Size);
  442.     if L <> 0 then begin
  443.       P := Ptr(Word(L and $FFFF), 0);
  444.       AllocBuffer := True;
  445.     end else begin
  446.       P := nil;
  447.       AllocBuffer := False
  448.     end;
  449. {$ELSE}
  450.     if MaxAvail >= Size then begin
  451.       GetMem(P, Size);
  452.       AllocBuffer := True;
  453.     end else begin
  454.       P := nil;
  455.       AllocBuffer := False;
  456.     end;
  457. {$ENDIF}
  458.   end;
  459.  
  460.   procedure FreeBuffer(P : Pointer; Size : Word);
  461.   begin
  462.     if P = nil then
  463.       Exit;
  464. {$IFDEF pmode}
  465.     Size := GlobalDosFree(LongInt(P) shr 16);
  466. {$ELSE}
  467.     FreeMem(P, Size);
  468. {$ENDIF}
  469.   end;
  470.  
  471.   function CheckParms(DType : DriveType; Drive : DriveNumber) : Boolean;
  472.     {-Make sure drive and type are within range}
  473.   begin
  474.     CheckParms := False;
  475.     if (DType < 1) or (DType > 4) then
  476.       Exit;
  477.     if (Drive > 7) then
  478.       Exit;
  479.     CheckParms := True;
  480.   end;
  481.  
  482.   function SubfSectors(SubFunc : Byte;
  483.                        Drive : DriveNumber;
  484.                        Track, Side, SSect, NSect : Byte;
  485.                        var Buffer) : Byte;
  486.     {-Code shared by ReadSectors, WriteSectors, VerifySectors, FormatTrack}
  487.   var
  488.     Tries : Byte;
  489.     Done : Boolean;
  490.     Regs : Registers;
  491.   begin
  492.     Tries := 1;
  493.     Done := False;
  494.     repeat
  495.       Regs.AH := SubFunc;
  496.       Regs.AL := NSect;
  497.       Regs.CH := Track;
  498.       Regs.CL := SSect;
  499.       Regs.DH := Side;
  500.       Regs.DL := Drive;
  501.       Regs.ES := Seg(Buffer);
  502.       Regs.BX := Ofs(Buffer);
  503.       Int13Call(Regs);
  504.  
  505.       if Regs.AH <> 0 then begin
  506.         ResetDrive(Drive);
  507.         Inc(Tries);
  508.         if Tries > MaxRetries then
  509.           Done := True;
  510.       end else
  511.         Done := True;
  512.     until Done;
  513.  
  514.     SubfSectors := Regs.AH;
  515.   end;
  516.  
  517.   function ReadSectors(Drive : DriveNumber;
  518.                        Track, Side, SSect, NSect : Byte;
  519.                        var Buffer) : Byte;
  520.   begin
  521.     ReadSectors := SubfSectors($02, Drive, Track, Side, SSect, NSect, Buffer);
  522.   end;
  523.  
  524.   function WriteSectors(Drive : DriveNumber;
  525.                         Track, Side, SSect, NSect : Byte;
  526.                         var Buffer) : Byte;
  527.   begin
  528.     WriteSectors := SubfSectors($03, Drive, Track, Side, SSect, NSect, Buffer);
  529.   end;
  530.  
  531.   function VerifySectors(Drive : DriveNumber;
  532.                          Track, Side, SSect, NSect : Byte) : Byte;
  533.   var
  534.     Dummy : Byte;
  535.   begin
  536.     VerifySectors := SubfSectors($04, Drive, Track, Side, SSect, NSect, Dummy);
  537.   end;
  538.  
  539.   function SetDriveTable(DType : DriveType) : Boolean;
  540.     {-Set drive table parameters for formatting}
  541.   var
  542.     P : Pointer;
  543.     DBSeg : Word;
  544.     DBOfs : Word;
  545.   begin
  546.     SetDriveTable := False;
  547.  
  548. {$IFDEF pmode}
  549.     GetRealIntVec($1E, P);
  550.     DBSeg := GetRealSelector(P, $FFFF);
  551.     if DBSeg = 0 then
  552.       Exit;
  553.     DBOfs := 0;
  554. {$ELSE}
  555.     GetIntVec($1E, P);
  556.     DBSeg := LongInt(P) shr 16;
  557.     DBOfs := LongInt(P) and $FFFF;
  558. {$ENDIF}
  559.  
  560.     {Set gap length for formatting}
  561.     case DType of
  562.       1 : Mem[DBSeg:DBOfs+7] := $50; {360K}
  563.       2 : Mem[DBSeg:DBOfs+7] := $54; {1.2M}
  564.       3,
  565.       4 : Mem[DBSeg:DBOfs+7] := $6C; {720K or 1.44M}
  566.     end;
  567.  
  568.     {Set max sectors/track}
  569.     Mem[DBSeg:DBOfs+4] := DData[DType].SPT;
  570.  
  571. {$IFDEF pmode}
  572.     DBSeg := FreeSelector(DBSeg);
  573. {$ENDIF}
  574.  
  575.     SetDriveTable := True;
  576.   end;
  577.  
  578.   function GetMachineID : Byte;
  579.     {-Return machine ID code}
  580. {$IFDEF pmode}
  581.   var
  582.     SegFFFF : Word;
  583. {$ENDIF}
  584.   begin
  585. {$IFDEF pmode}
  586.     SegFFFF := GetRealSelector(Ptr($FFFF, $0000), $FFFF);
  587.     if SegFFFF = 0 then
  588.       GetMachineID := 0
  589.     else begin
  590.       GetMachineID := Mem[SegFFFF:$000E];
  591.       SegFFFF := FreeSelector(SegFFFF);
  592.     end;
  593. {$ELSE}
  594.     GetMachineID := Mem[$FFFF:$000E];
  595. {$ENDIF}
  596.   end;
  597.  
  598.   function IsATMachine : Boolean;
  599.     {-Return True if AT or better machine}
  600.   begin
  601.     IsATMachine := False;
  602.     if Lo(DosVersion) >= 3 then
  603.       case GetMachineId of
  604.         $FC, $F8 :  {AT or PS/2}
  605.           IsATMachine := True;
  606.       end;
  607.   end;
  608.  
  609.   function GetChangeLineType(Drive : DriveNumber; var CLT : Byte) : Byte;
  610.     {-Return change line type of drive}
  611.   var
  612.     Regs : Registers;
  613.   begin
  614.     Regs.AH := $15;
  615.     Regs.DL := Drive;
  616.     Int13Call(Regs);
  617.     if (Regs.Flags and FCarry) <> 0 then begin
  618.       GetChangeLineType := Regs.AH;
  619.       CLT := 0;
  620.     end else begin
  621.       GetChangeLineType := 0;
  622.       CLT := Regs.AH;
  623.     end;
  624.   end;
  625.  
  626.   function SetFloppyType(Drive : DriveNumber; FType : Byte) : Byte;
  627.     {-Set floppy type for formatting}
  628.   var
  629.     Tries : Byte;
  630.     Done : Boolean;
  631.     Regs : Registers;
  632.   begin
  633.     Tries := 1;
  634.     Done := False;
  635.     repeat
  636.       Regs.AH := $17;
  637.       Regs.AL := FType;
  638.       Regs.DL := Drive;
  639.       Int13Call(Regs);
  640.       if Regs.AH <> 0 then begin
  641.         ResetDrive(Drive);
  642.         Inc(Tries);
  643.         if Tries > MaxRetries then
  644.           Done := True;
  645.       end else
  646.         Done := True;
  647.     until Done;
  648.  
  649.     SetFloppyType := Regs.AH;
  650.   end;
  651.  
  652.   function SetMediaType(Drive : DriveType; TPD : Byte; SPT : Byte) : Byte;
  653.     {-Set media type for formatting}
  654.   var
  655.     Regs : Registers;
  656.   begin
  657.     Regs.AH := $18;
  658.     Regs.DL := Drive;
  659.     Regs.CH := TPD;
  660.     Regs.CL := SPT;
  661.     Int13Call(Regs);
  662.     SetMediaType := Regs.AH;
  663.   end;
  664.  
  665.   function FormatDisk(Drive : DriveNumber; DType : DriveType;
  666.                       Verify : Boolean; MaxBadSects : Byte;
  667.                       VLabel : VolumeStr;
  668.                       FAF : FormatAbortFunc) : Byte;
  669.   label
  670.     ExitPoint;
  671.   type
  672.     CHRNRec =
  673.       record
  674.         CTrack : Byte;            {Track  0..?}
  675.         CSide : Byte;             {Side   0..1}
  676.         CSect : Byte;             {Sector 1..?}
  677.         CSize : Byte;             {Size   0..?}
  678.       end;
  679.     CHRNArray = array[1..18] of CHRNRec;
  680.     FATArray = array[0..4607] of Byte;
  681.   var
  682.     Tries : Byte;
  683.     Track : Byte;
  684.     Side : Byte;
  685.     Sector : Byte;
  686.     SecWritten : Byte;
  687.     SecRsvd : Byte;
  688.     FatNum : Byte;
  689.     BadSects : Byte;
  690.     ChangeLine : Byte;
  691.     DiskType : Byte;
  692.     Status : Byte;
  693.     SaveMaxRetries : Byte;
  694.     VLabelI : Byte;
  695.     Done : Boolean;
  696.     SecNum : Word;
  697.     Trash : Word;
  698.     DT : DateTime;
  699.     VDate : LongInt;
  700.     Regs : Registers;
  701.     BootPtr : ^SectorArray;
  702.     CHRN : ^CHRNArray;
  703.     FATs : ^FATArray;
  704.  
  705.     procedure MarkBadSector(SecNum : Word);
  706.       {-Assumes SecNum > SecRsvd}
  707.     const
  708.       BadMark = $FF7;             {Bad cluster mark}
  709.     var
  710.       ClusNum : Word;             {Cluster number}
  711.       FOfs : Word;                {Offset into fat for this cluster}
  712.       FVal : Word;                {FAT value for this cluster}
  713.       OFVal : Word;               {Old FAT value for this cluster}
  714.     begin
  715.       ClusNum := ((SecNum-SecRsvd) div DData[DType].BRD[0])+2;
  716.       FOfs := (ClusNum*3) div 2;
  717.       Move(FATs^[FOfs], FVal, 2);
  718.       if Odd(ClusNum) then
  719.         OFVal := (FVal and (BadMark shl 4))
  720.       else
  721.         OFVal := (FVal and BadMark);
  722.       if OFVal = 0 then begin
  723.         {Not already marked bad, mark it}
  724.         if Odd(ClusNum) then
  725.           FVal := (FVal or (BadMark shl 4))
  726.         else
  727.           FVal := (FVal or BadMark);
  728.         Move(FVal, FATs^[FOfs], 2);
  729.         {Add to bad sector count}
  730.         if MaxBadSects <> 0 then
  731.           Inc(BadSects, DData[DType].BRD[0]);
  732.       end;
  733.     end;
  734.  
  735.   begin
  736.     {Validate parameters. Can't do anything unless these are reasonable}
  737.     if not CheckParms(DType, Drive) then
  738.       Exit;
  739.  
  740.     {Initialize buffer pointers in case of failure}
  741.     FATs := nil;
  742.     CHRN := nil;
  743.     BootPtr := nil;
  744.  
  745.     {Status proc: starting format}
  746.     if FAF(0, DData[DType].TPD, 0) then begin
  747.       Status := $FA;
  748.       goto ExitPoint;
  749.     end;
  750.  
  751.     {Error code for invalid drive or media type}
  752.     Status := $FE;
  753.  
  754.     case GetDriveType(Drive) of
  755.       1 : {360K drive formats only 360K disks}
  756.         if DType <> 1 then
  757.           goto ExitPoint;
  758.       2 : {1.2M drive formats 360K or 1.2M disk}
  759.         if DType > 2 then
  760.           goto ExitPoint;
  761.       3 : {720K drive formats only 720K disks}
  762.         if DType <> 3 then
  763.           goto ExitPoint;
  764.       4 : {1.44M drive formats 720K or 1.44M disks}
  765.         if Dtype < 3 then
  766.           goto ExitPoint;
  767.     else
  768.       goto ExitPoint;
  769.     end;
  770.  
  771.     {Error code for out-of-memory or DPMI error}
  772.     Status := $FF;
  773.  
  774.     {Allocate buffers}
  775.     if not AllocBuffer(Pointer(FATs), SizeOf(FATArray)) then
  776.       goto ExitPoint;
  777.     if not AllocBuffer(Pointer(CHRN), SizeOf(CHRNArray)) then
  778.       goto ExitPoint;
  779.     if not AllocBuffer(Pointer(BootPtr), SizeOf(BootRecord)) then
  780.       goto ExitPoint;
  781.  
  782.     {Initialize boot record}
  783.     Move(BootRecord, BootPtr^, SizeOf(BootRecord));
  784.     Move(DData[DType].BRD, BootPtr^[13], 14);
  785.  
  786.     {Initialize the FAT table}
  787.     FillChar(FATs^, SizeOf(FATArray), 0);
  788.     FATs^[0] := DData[DType].FID;
  789.     FATs^[1] := $FF;
  790.     FATs^[2] := $FF;
  791.  
  792.     {Set drive table parameters by patching drive table in memory}
  793.     if not SetDriveTable(DType) then
  794.       goto ExitPoint;
  795.  
  796.     {On AT class machines, set format parameters via BIOS}
  797.     if IsATMachine then begin
  798.       {Get change line type: 1 -> 360K drive, 2 -> 1.2M or 3.5" drive}
  799.       Status := GetChangeLineType(Drive, ChangeLine);
  800.       if Status <> 0 then
  801.         goto ExitPoint;
  802.       if (ChangeLine < 1) or (ChangeLine > 2) then begin
  803.         Status := 1;
  804.         goto ExitPoint;
  805.       end;
  806.  
  807.       {Determine floppy type for SetFloppyType call}
  808.       DiskType := MediaArray[DType, ChangeLine];
  809.       if DiskType = 0 then begin
  810.         Status := $FB;
  811.         goto ExitPoint;
  812.       end;
  813.  
  814.       {Set floppy type for drive}
  815.       Status := SetFloppyType(Drive, DiskType);
  816.       if Status <> 0 then
  817.         goto ExitPoint;
  818.  
  819.       {Set media type for format}
  820.       Status := SetMediaType(Drive, DData[DType].TPD, DData[DType].SPT);
  821.       if Status <> 0 then
  822.         goto ExitPoint;
  823.     end;
  824.  
  825.     {Format each sector}
  826.     ResetDrive(Drive);
  827.     BadSects := 0;
  828.     SecRsvd := (2*DData[DType].SPF)+DData[DType].DSC+2;
  829.     SaveMaxRetries := MaxRetries;
  830.  
  831.     for Track := 0 to DData[DType].TPD do begin
  832.       {Status proc: formatting track}
  833.       if FAF(Track, DData[DType].TPD, 1) then begin
  834.         Status := $FA;
  835.         goto ExitPoint;
  836.       end;
  837.  
  838.       for Side := 0 to 1 do begin
  839.         {Initialize CHRN for this sector}
  840.         for Sector := 1 to DData[DType].SPT do
  841.           with CHRN^[Sector] do begin
  842.             CTrack := Track;
  843.             CSide := Side;
  844.             CSect := Sector;
  845.             CSize := DData[DType].SSZ;
  846.           end;
  847.  
  848.         {Format this sector, with retries}
  849.         Status := SubfSectors($05, Drive, Track, Side,
  850.                               1, DData[DType].SPT, CHRN^);
  851.         if Status <> 0 then
  852.           goto ExitPoint;
  853.       end;
  854.  
  855.       if Verify then begin
  856.         {Status proc: verifying track}
  857.         if FAF(Track, DData[DType].TPD, 2) then begin
  858.           Status := $FA;
  859.           goto ExitPoint;
  860.         end;
  861.  
  862.         for Side := 0 to 1 do
  863.           {Verify the entire track}
  864.           if VerifySectors(Drive, Track, Side,
  865.                            1, DData[DType].SPT) <> 0 then begin
  866.             {Mark bad sectors}
  867.             MaxRetries := 1;
  868.             for Sector := 1 to DData[DType].SPT do begin
  869.               Status := VerifySectors(Drive, Track, Side, Sector, 1);
  870.               if Status <> 0 then begin
  871.                 SecNum := (Word(2)*Track+Side)*DData[DType].SPT+Sector;
  872. {$IFDEF Debug}
  873.                 writeln(^M^J'Track=',Track,
  874.                         ' Side=',Side,
  875.                         ' Sector=',Sector,
  876.                         ' SecNum=',SecNum,
  877.                         ' Status=',Status);
  878. {$ENDIF}
  879.                 if SecNum <= SecRsvd then begin
  880.                   {No errors allowed in boot sect, FATs, or dir: Disk bad}
  881.                   Status := $FD;
  882.                   goto ExitPoint;
  883.                 end;
  884.                 MarkBadSector(SecNum);
  885.                 if BadSects > MaxBadSects then begin
  886.                   Status := $FC;
  887.                   goto ExitPoint;
  888.                 end;
  889.               end;
  890.             end;
  891.             MaxRetries := SaveMaxRetries;
  892.           end;
  893.       end;
  894.     end;
  895.  
  896.     {Status proc: writing boot and FAT}
  897.     if FAF(0, DData[DType].TPD, 3) then begin
  898.       Status := $FA;
  899.       goto ExitPoint;
  900.     end;
  901.  
  902.     {Write boot record}
  903.     Status := WriteSectors(Drive, 0, 0, 1, 1, BootPtr^);
  904.     if Status <> 0 then begin
  905.       Status := $FD;
  906.       goto ExitPoint;
  907.     end;
  908.  
  909.     {Write FATs and volume label}
  910.     Track := 0;
  911.     Side := 0;
  912.     Sector := 2;
  913.     FatNum := 0;
  914.     for SecWritten := 0 to SecRsvd-3 do begin
  915.       if Sector > DData[DType].SPT then begin
  916.         Sector := 1;
  917.         Inc(Side);
  918.       end;
  919.  
  920.       if SecWritten < (2*DData[DType].SPF) then begin
  921.         if FatNum > DData[DType].SPF-1 then
  922.           FatNum := 0;
  923.       end else begin
  924.         FillChar(FATs^, 512, 0);
  925.         if ((VLabel <> '') and (SecWritten = 2*DData[DType].SPF)) then begin
  926.           {Put in volume label}
  927.           for VLabelI := 1 to Length(VLabel) do
  928.             VLabel[VLabelI] := Upcase(VLabel[VLabelI]);
  929.           while Length(VLabel) < 11 do
  930.             VLabel := VLabel+' ';
  931.           Move(VLabel[1], FATs^, 11);
  932.           FATs^[11] := 8;
  933.           GetDate(DT.Year, DT.Month, DT.Day, Trash);
  934.           GetTime(DT.Hour, DT.Min, DT.Sec, Trash);
  935.           PackTime(DT, VDate);
  936.           Move(VDate, FATs^[22], 4);
  937.         end;
  938.         FatNum := 0;
  939.       end;
  940.  
  941.       if WriteSectors(Drive, Track, Side,
  942.                       Sector, 1, FATs^[FatNum*512]) <> 0 then begin
  943.         Status := $FD;
  944.         goto ExitPoint;
  945.       end;
  946.  
  947.       Inc(Sector);
  948.       Inc(FatNum);
  949.     end;
  950.  
  951.     {Success}
  952.     Status := 0;
  953.  
  954. ExitPoint:
  955.     FreeBuffer(BootPtr, SizeOf(BootRecord));
  956.     FreeBuffer(CHRN, SizeOf(CHRNArray));
  957.     FreeBuffer(FATs, SizeOf(FATArray));
  958.  
  959.     {Status proc: ending format}
  960.     Done := FAF(Status, DData[DType].TPD, 4);
  961.     FormatDisk := Status;
  962.   end;
  963.  
  964.   function EmptyAbortFunc(Track, MaxTrack : Byte; Kind : Byte) : Boolean;
  965.   begin
  966.     EmptyAbortFunc := False;
  967.   end;
  968.  
  969. end.
  970.