{$B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}
{$M 65500,16384,33000} {Turbo 3 default stack and heap}


{$R+}

program readmorrow;
(* special version to read Morrow CP/M diskettes as default if not Heath *)
(* TP4.0 version *)

{  xx $I cpmconst.inc }

Uses
  Crt,
  Dos,
  Printer;

const
    short  = 1000; { delays for pauses }
    medium = 2000;
    long   = 3000;
    buffersize = $3000; { 12k buffer space }
    MAXTRIES   = 2;     { number of times to try diskio before giving up }
    maxdirs    = $400;  { maximum number of directory entries }
    drivemax   = 4;
    getintrp   = $35;   { dos 21 int functions }
    setintrp   = $25;

    disktable  = $1E;   { disk parameter block has address stored here }
    equip      = $11;

    diskio     = $13;   { does the dirty work }
    diskreset  = $00;   { put one of these in ah for intr $13 }
    diskstatus = $01;
    diskread   = $02;
    diskwrite  = $03;
    diskverify = $04;
    diskformat = $05;
    onesector  = $01;  { in al }
    phys       : array[0..3] of integer = (128,256,512,1024);
    carryflag  = $01;

    MAXsector  = 40;   { max sector number on a track }
    driveflag  = $00c1 ;
illegal : set of char = [' ','<','>','+','=','"','''','{','}',']','[',')','('];



{xx $I cpmtypes.inc }

type
   buffertype= array[0..buffersize] of byte;
   bufferptr = ^buffertype;
   anystring = string[255];
   nstring = string[64]; { suitable for DOS,CP/M names }
   paramptr = ^params;
   params = record     { disk parameter block }
                       { don't change for 512 byte disks }
              dmode1 : byte;
              dmode2 : byte;
              clocktick : byte;
              bytesector : byte; { 0..3 128..512 }
              lastsector : byte;
              gaplen : byte;
              datalen : byte;
              gaplenformat : byte;
              formatchar : byte;
              headsettle : byte;
              motorstart : byte;
            end;

cpmdpb  =  record  { standard CP/M disk parameters }
            spt : integer;
            bsh : byte;
            blm : byte;
            exm : byte;
            dsm : integer;
            drm : integer;
            all01 : integer;
            cks   : integer;
            off   : integer;
            end;
morrowlabel = record { has dpb + checksum }
            mdpb : cpmdpb;
            mcksum: byte;
            end;

heathext =  record { header on label before the dpb }
           ver   : byte;
           typef : byte;
           select: byte;
           rps   : byte;  { cpm sectors / physical sector }
           rab   : byte;  { cpm sectors / allocation block }
           trk   : byte;
           speed : byte;
           sflag : byte;  { second flag byte }
           lun   : byte; { last logical unit mounted }
           end;  { 8 bytes }

heathlabel = record
           JUMP  : array[0..3] of byte;
           ext   : heathext;
           dpb   : cpmdpb;
           cksum : byte;
          end;

labelptr = ^heathlabel;
mlabelptr =^morrowlabel;
fakelabel = array[0..$1c] of byte; { at its barest }
fakelabelptr = ^fakelabel;


fcb1   = array[0..12] of byte;
fcb1ptr = ^fcb1;
cpmdir = record
              key :  fcb1;
              junk : integer;
              many : byte;
              block : array[0..15] of byte; { may be byte or integers }
              { redo as a variant record later }
              end;
cpmdirptr   = ^cpmdir;

{xx  $I cpmvars.inc }

var
    c,chh : char;
  ch2 : char;
  Cmmdline : nstring;

{ ROM parameters for floppies }
    myROMparams    : params;
    oldROMparms : paramptr;
    filler      : array[0..413] of byte; { got a 64k boundary notice }

    buffer      : bufferptr;
                  {largest allocation block to read in from floppy }
    drivename   : string[10];
    drivenumber : INTEGER;
    dosfile     : file of byte;
    dosname     : string[96];
    havelogged  : boolean;

{ cp/m label, including dpb }

    defaultlabel,morrowds, morrowss : heathlabel;     { default label is a holding tank }
    mylabel      : heathlabel;     { for labels read off disk before }
                                   { validity is verified  }
                                   { mylabel is the working label }

{ global variables calculated from heath label }

    totalspace  : integer;
    freespace   : integer; { in 1k's }
    is2sided    : boolean;
    totaltracks : integer;
    log2phys    : integer;
    secsize     : integer;   { 1,2, or 3 for 256, 512 or 1024 byte sectors }
    sectortrack : integer;
    directory   : array[0..maxdirs] of cpmdir;
    a           : array[0..maxdirs] of cpmdirptr;
    alloc       : array[0..1023] of boolean; { to map the usage }
    dirsectors  : integer; { number of physical sectors in the directory }
    numdir      : integer; { number of directory entries for current format }
    blkaddrbyte : boolean;
                  {true if 1 byte entries, false if 2 bytes in directory }
    numblk      : integer; { blocks reserved for directory }
    kperblk     : integer; { kilobytes per block }
    currentdir  : integer; { a[currentdir] is cpmdirptr,
                             pointing to directory entry }
    extent      : array[0..1023] of integer;
    counter     : integer;
    activefilename : string[20]; { current file name }
    buffercount   : integer  ; { current load  in buffer[ ] }
    phys2alloc  : integer;
    sizealloc   : integer;
    stupid86    : boolean; { global flag for pc cp/m-86 double sided format }
    ismorrow    : boolean;
    SECTORSKEW  : integer;
    debugfile : file of byte;

const

{ related to disk labels }
{ from h37 bios listing }
    dpeh37 = $60;  { h37 controller, different for z100-cp/m-85 }
    dpez100= $20;  { z100 CP/M-85 ID flag }
    dpe96t = $08;  { 96 tpi drives }
    dpeed  = $04;  { extended density, 5 1k sectors per track }
    dpedd  = $02;  { double density versus single density }
    dpe2s  = $01;  { double sided }

    cpm86ds  = $80  ; { private CWW flag for secondary flag to indicate }
    { pc cpm/86 double sided format }
    { some versions of my cp/m bios have another bit to mark Lobo format }
    { where physical sector numbering begins  with 0 }
    { a variant I haven't solved is the Zorba format with sector numbering}
    { wrapping around to the back of a cylinder. I.e., side 0 1..5, side 1 }
    { 6..10, with side flag not set for side 1 !!!!! This is not readable }
    { by the 1797 but is by the 1793 }



{xx $I utility.inc }
{ include file utility.inc from readcpm }

{ get integral part of base 2 log }
function log2( x : integer) : integer;
var i : integer;
begin
  i:=0;
  if x < 0 then x:=-x; { positive x }
  x:=x and $1f; { not too large }
  repeat
    x:=x div 2;
    if x <> 0 then i:=i+1;
 until x = 0;
 log2:=i;
end; { log2 }

procedure beep;
{ error warning }
begin
  write(chr(7),chr(7),chr(7));
end; { beep }

function max (x,y : integer) : integer;
begin
  if x <= y then max:=y else max:=x;
end;  { max }


function min (x,y : integer) : integer;
begin
  if x <= y then min:=x else min:=y;
end;  { min }

function dyadic ( x: integer ) : integer;
{ returns number of 1's in the binary expansion of x }
var sum,power2,i : integer;
begin
  sum:=0;
  power2:=1;
  for i:=0 to 15 do begin
    if x and power2 <> 0 then sum:=sum+1;
    power2:=power2 shl 1;
 end;
 dyadic:=sum;
end; { dyadic }

procedure sorry;
begin
   writeln;
   clreol;
   writeln('Sorry, have to login the MORROW CP/M disk first.');
   writeln;
end; { sorry }

procedure presscrlf;
var ch : char;
begin
  writeln;clreol;
  writeln('Press <CR> to continue.');
  repeat
     ch:=readkey;
  until ch=#$0d;
  writeln;
end; { presscrlf }

procedure insertdisk;
begin
  writeln;
  writeln('Insert diskette in drive ',chr(65+drivenumber),': ');
  presscrlf;
end; { insertdisk }

{xx $I standard.inc}

function checkabort : boolean;
{ check keyboard , if no key pressed, return false }
{ if ^C or ^Z, return true }
{ if ^S return false after getting next char }
var ch,ch1 : char;

begin
  checkabort:=false;
  if keypressed then begin
     ch:=readkey;
     case ch of
      ^C,^Z : checkabort:=true;
      ^S    : begin
                 while keypressed do ch:=readkey; { empty queue }
                 ch1:=readkey; { get it, ignore }
                 if ch1=^C then checkabort:=true;
                 if ch1=^Z then checkabort:=true;
               end;
      else begin end; { do nothing otherwise }
     end;   { end of case }
   end;  { if then }
end; { checkabort }

procedure notimplemented;
begin
  writeln;
  writeln('Procedure not yet implemented.');
  writeln;
end;

procedure getdosname(s: nstring ; var dosfile : FILE);
var
   name : string[64]; { long path name }
   myio : integer;
begin
   repeat
      write(s);
      readln(dosname);
      assign(dosfile,dosname);
      {$I-}
      rewrite(dosfile);
      myio:=ioresult;
      {$I+}
   until myio = 0;
end; { getdosname }

procedure openwDOS(s: nstring ; var dosfile : text);
{ open for writing text files }
var
   name : string[64]; { long path name }
   myio : integer;
begin
   repeat
      write(s);
      readln(dosname);
      assign(dosfile,dosname);
      {$I-}
      rewrite(dosfile); myio:=ioresult;
      {$I+}
   until myio = 0;
end; { openwdos }

function openrDOS(s: nstring ; var dosfile : text) : boolean;
{ open for reading text files }
var
   name : string[64]; { long path name }
   trys : integer;
   iochk: integer;
begin
   openrdos:=true; { optimist }
   trys:=2;
   repeat
      write(s);
      readln(dosname);
      assign(dosfile,dosname);
      {$I-}
      reset(dosfile);iochk:=ioresult;
      {$I+}
      trys:=trys-1;
   until (iochk = 0) or (trys <= 0);
   if trys <=0 then begin
      clreol;
      writeln('File read attempt aborted.');
      openrdos:=false;
   end;
end; { openrdos }

{xx $I ROMERR.INC }

procedure errormsg( x : byte);
begin
   writeln;
   case x of
      0   : writeln('No error.');
      1   : writeln('Bad command.');
      2   : writeln('Bad address mark.');
      3   : writeln('Write-protected disk.');
      4   : writeln('Record not found.');
      5   : writeln('Controller reset failed.');
      7   : writeln('Controller won''t accept drive parameters.');
      8   : writeln('DMA overrun.');
      9   : writeln('DMA bounds error.');
      $0b : writeln('Bad track flag found.');
      $10 : writeln('Bad CRC on disk read.');
      $11 : writeln('Recoverable ECC error.');
      $20 : writeln('Disk controller chip failure.');
      $40 : writeln('Bad seek.');
      $80 : writeln('Time out error.');
      $BB : writeln('Undefined error.');
      $ff : writeln('Sense Drive Status failure.');
    end;
    writeln;
 end; { error msg }


procedure setparmptr( x : paramptr );
   var y : Registers;
begin
   y.ah:=setintrp ;
   y.al:=disktable;
   y.dx:=ofs( x^);
   y.ds:=seg(x^);
   msdos(Dos.Registers(y));  { set the interrupt  block to point to our block }
end; { set }

procedure getparmptr( var x : paramptr );
   var y : Registers;
begin
   y.ah:= getintrp;
   y.al:=disktable;
   msdos(Dos.Registers(y));
   x:= ptr(y.es,y.bx);
end; { getpar }

procedure smooth;
{ have to get this to be only exit }
{ and make sure it restores disk params to normal }
begin
  setparmptr(oldROMparms);
end; { smoothexit }

procedure initdefault;
var i : integer;
begin

   with defaultlabel do
   begin
      for i:=0 to 3 do JUMP[i]:= $E5;
      ext.ver :=$00;
      ext.typef:=$67 ;
      ext.select:=$E5;
      ext.rps:=$04;
      ext.rab:=$10;
      ext.trk:=$E5;
      ext.speed:=$E5;
      ext.sflag:=$00;
      ext.lun:=$E5;
      dpb.spt:=$0024;
      dpb.bsh:=$04;
      dpb.blm:=$0F;
      dpb.exm:=$01;
      { Heath CP/M 2.203 format program has a bug that sets this to 0 }
      dpb.dsm:=$00AE;
      dpb.drm:=$007F;
      dpb.all01:=$00C0;
      dpb.cks:=$0020;
      dpb.off:=$0002;
      cksum:=$00a9;
  end;

   with morrowss do
   begin
      for i:=0 to 3 do JUMP[i]:= $E5;
      ext.ver :=$00;
      ext.typef:=$66 ;
      ext.select:=$E5;
      ext.rps:=$08;
      ext.rab:=$10;
      ext.trk:=$E5;
      ext.speed:=$E5;
      ext.sflag:=$00;
      ext.lun:=$E5;
      dpb.spt:=$0028;
      dpb.bsh:=$04;
      dpb.blm:=$0F;
      dpb.exm:=$01;
      dpb.dsm:=$005E;
      dpb.drm:=$007F;
      dpb.all01:=$00C0;
      dpb.cks:=$0020;
      dpb.off:=$0002;
      cksum:=$0000;
  end;

 with morrowds do
   begin
      for i:=0 to 3 do JUMP[i]:= $E5;
      ext.ver :=$00;
      ext.typef:=$67 ;
      ext.select:=$E5;
      ext.rps:=$08;
      ext.rab:=$10;
      ext.trk:=$E5;
      ext.speed:=$E5;
      ext.sflag:=$00;
      ext.lun:=$E5;
      dpb.spt:=$0028;
      dpb.bsh:=$04;
      dpb.blm:=$0F;
      dpb.exm:=$01;
      dpb.dsm:=$00C2;
      dpb.drm:=$00BF;
      dpb.all01:=$00E0;
      dpb.cks:=$0030;
      dpb.off:=$0002;
      cksum:=$0000;
  end;

end; { initdefault to MORROW dd ds 5 1024 byte sectors/track }

{xx $I hex.inc }

{ display module }
const
   hexint : string[16] = '0123456789ABCDEF';

procedure putnibble(x: integer);
begin
   x:=x and $0f;
   write(hexint[x+1]);
end;

procedure putbyte( x: integer);
begin
   x:= x and $ff;
   putnibble((x and $f0) shr 4);
   putnibble( x and $0f);
end;

{xx $I get.inc }

function getdrives : integer;
var x : Registers;
    y : integer;
begin
  { returns number of floppy drives }
  intr(equip,Dos.Registers(x));
  y:=x.ax and ($00c1);
   { stupid ibm scheme, bit 0 = 0 => no drives }
   { bit 0 = 1 => bits 6,7 give number -1 }
 if ((y and 1) = 0) then getdrives:=0 else
  begin
     y:=y shr 6;
     y:=y and 3;
     getdrives:=y+1;
  end;
end; { getdrives }

procedure getdrive;
var ch : char;
begin
  repeat
      clreol;
      write('Which drive for MORROW CP/M disk? <B:>  ');
      ch:=readkey;
      writeln;
      if ch = #$0d then ch:='B' else ch:=upcase(ch);
      drivenumber:=ord(ch) - ord('A');
  until (ch in ['A'..'P']) and (drivenumber < 4 );
 end; { getdrive }

{ change cp/m track/sector to track/side/sector }
{ adjust for cp/m-86 format here }

procedure convert(var trk,side,sec : integer);
begin
  if (is2sided and not stupid86) then begin
       side:= trk mod 2;
       if side < 0 then side:=1;
       trk:=trk div 2;
  end;
  if not is2sided then side:=0;
  if (is2sided and stupid86) then begin
      if trk > 39 then side:=1 else side:=0;
      if trk > 39 then trk:= 79-trk;
  end;
end; { convert }

procedure alloc2trksec(n : integer; var trak,side,sect : integer);
begin
    trak:=(n*mylabel.ext.rab) div  mylabel.dpb.spt;
    trak:=trak+mylabel.dpb.off; { adjust for reserved tracks }
    sect:=((n*mylabel.ext.rab) mod  mylabel.dpb.spt) div mylabel.ext.rps;
    sect:=sect+1; { make it  1..maxsec }
    side:=0;
end; { alloctrksec }

{xx $I readsec.inc}

function readsec(VAR  trk,side,sector : integer) : boolean;
var z : Registers;
    errflag : integer;
    errcount : integer;

procedure tryagain;  { put in a block for repeats }
begin
   myROMparams.bytesector:=secsize;
   myROMparams.lastsector:=sectortrack + 1 ;
   z.dl:= drivenumber;
   z.dh:= side;
   z.ch:= lo(trk);
   z.cl:= lo(sector);
   z.ah:= diskread ;
   z.al:= ONESECTOR;
   z.es:= seg(buffer^[buffercount]);
   z.bx:= ofs(buffer^[buffercount]);
   intr(DISKIO,Dos.Registers(z));
   smooth;
end; { tryagain }

begin  { readsec }
 errcount:=MAXTRIES;
  repeat
   { switch to my parameters }
   setparmptr(addr(myROMparams)); { point to my table }
   readsec:=false;
   tryagain;
   errflag:=z.flags and carryflag;
   errcount:=errcount-1;
   if errflag<> 0 then beep;
  until (errflag=0) or (errcount <= 0);
   if errflag <> 0 then begin
      errormsg(z.ah);
      readsec:=false;
   end else readsec:=true;
end; { readsec read 1 physical sector }

{ function below translates logical to phyical sectors, then reads physical }
function logreadsec(VAR  trk,side,sector : integer) : boolean;
var maxsector,logsector : integer;
begin
  maxsector:=sectortrack;
  if sectorskew = 0 then logsector:=sector
  else logsector:= (1+ ((sector-1)*sectorskew)) mod maxsector;
  if logsector=0 then logsector:=maxsector;
  logreadsec:=readsec(trk,side,logsector);
end; {logreadsec}


function firstread  : boolean; { read absolute sector 0 }
{ tries to read sector 1 of track 0, side 0. If cannot read with }
{ sector sizes 256, 512, or 1024, declares failure, returns }
{ false. Else returns true, with this sector in the buffer }

label 123;
var z :  Registers;
    i :  integer;           { test with sector 1, track 1, side 0 }
    errorcnt : integer;
    errflag : integer;
procedure try(i : integer);
begin
   secsize:=i;
   myROMparams.bytesector:=lo(i);
   z.dl:= DRIVENUMBER;
   z.dh:= 0 ; { side }
   z.ch:= 0 ; { track }
   z.cl:= 1;  { sector number }
   z.ah:= diskread;
   z.al:= 1;  { number of sectors to transfer }
   z.es:= seg(buffer^[0]);
   z.bx:= ofs(buffer^[0]);
   intr(DISKIO,Dos.Registers(z));
end; { try }
begin
 buffercount:=0;
 firstread:=false;
 setparmptr(addr(myROMparams));
 for i:=3 downto 1  do begin
   errorcnt:=MAXTRIES; { set max num of retries }
   repeat
       try(i);
       errorcnt:=errorcnt-1;
       errflag:=z.flags and carryflag;
   until (errorcnt <= 0) or (errflag =0);
   if (errflag <> 0) and (i = 1)  then
        errormsg(z.ah);
   if errflag = 0 then begin
      writeln;
      writeln(phys[i],' bytes per sector.');
      firstread:=true;
      goto 123;
   end;
 end;
123:
     log2phys:= phys[secsize] div 128;
     smooth; { restore old parameters }
end; { firstread }

function  trksec2alloc ( trak,side,sec : integer) : integer;
{ take CP/M track sector, give CP/M allocation BLOCK }
{ -1 if on reserved track }
label 5555;
var sectors : integer;
begin
    { adjust  physical tracks, side to cpm tracks }
    if not is2sided then begin
         trak:=trak-mylabel.dpb.off;
         side:=0;
    end else trak:=(2*trak)-mylabel.dpb.off;
    if trak < 0 then begin
         trksec2alloc:=-1;
         goto 5555;
    end;
    { get the number of sectors before the trak }
    if is2sided then sectors:=(trak + side)*mylabel.dpb.spt;
    sectors:=sectors div mylabel.ext.rps; { make it physical }
    sectors:=sectors+(sec-1);
    sectors:=sectors div phys2alloc;
    trksec2alloc:=sectors;
5555:
end; { trksec2alloc }

{xx $I advance.inc }

procedure advance( var trk, side, sec : integer );
begin
{ go to next sector on basis of known disk parameters }
  if sec in [1..sectortrack-1] then sec:=sec+1
  else if sec=sectortrack then begin
      sec:=1;
      if (side=0) and is2sided then side:=1
      else if (side=1) and is2sided then begin
         side:=0;
         trk:=(trk+1) mod totaltracks;
      end else if not is2sided then
         trk:=(trk+1) mod totaltracks;
  end;
end; { advance }


procedure smoothexit;
begin
  smooth;
  halt;
end;

function chklabel( z : labelptr) : byte;
{ computes checksum of label. Should be 0 for valid heath label }
var i,sum : integer;
      y : fakelabelptr;
begin
  y:=addr(z^);
  sum:=1;  { 2's complement }
  for i:=4 to $1c do sum:=sum + y^[i];
  chklabel:=lo(sum);
end; { chklabel }

function ckmorrow( z : mlabelptr) : byte;
{ computes checksum of label. Should be ? for valid morrow label }
var i,sum : integer;
      y : fakelabelptr;
begin
  y:=addr(z^);
  sum:=-$3c;  { 2's complement }
  for i:=0 to $4 do sum:=sum + y^[i];
  ckmorrow:=lo(sum);
end; { ckmorrow }

procedure setlabel( x : heathlabel);
begin
  mylabel:=x;
  with mylabel do begin
    is2sided:=(ext.typef and dpe2s <> 0);
    totaltracks:=dpb.off + (((dpb.dsm+1) * ext.rab) div dpb.spt);
    if (totaltracks mod 40 ) <> 0 then totaltracks:=totaltracks + 1;
    sectortrack:=dpb.spt div ext.rps;
    { calculate total space }
    kperblk:=ext.rab div 8;
    totalspace:=((dpb.dsm+1)*ext.rab)  div 8; { to get in k's }
    freespace:=totalspace;
    {calculate number of physical sectors in the directory }
    dirsectors:= ( (dpb.drm + 1) div 4 ) div ext.rps;
    numdir := dpb.drm; { count from 0 to drm }
    blkaddrbyte:= ( dpb.dsm < 256 ); { less than 256 blocks per disk ? }
    { this should be a function of the exm mask also }
    { this is technically correct. However, some Heath formats used less
    than 256 blocks, and only put 8 blocks in a directory entry as bytes
    instead of 16. The original 1k ds dd format is an example. This is
    transparent to the user. The exm byte should have been 1 for these, but
    was incorrectly set as 0. Hence we should read the exm value rather than
    calculating it from the other parameters }
    numblk:=dyadic(dpb.all01);
    { now compute sector size }
    { get from number of cpm sectors per physical sectors in ext.rps }
    secsize    := log2((ext.rps) and $0f);
    log2phys   := phys[secsize] shr 7;
    phys2alloc := x.ext.rab div x.ext.rps;
    sizealloc  := x.ext.rab shl 7;
    stupid86   := ((x.ext.sflag and CPM86DS) <> 0 );
 end; { with }
end; { setlabel }

procedure readdir;
var i,trk,side,sec,x,y : integer;
    ch3 : char;
begin
   fillchar(buffer^[0],buffersize,$e5);
   fillchar(directory,maxdirs*32,$e5); { blank it }
   trk:=mylabel.dpb.off;
   side:=0;
   sec:=1;
   convert(trk,side,sec);
   y:=phys[secsize]; { bytes per physical sector }
   x:=y shr 5; { cpm directory entries per physical sector }
   for i:=0 to dirsectors-1 do begin
       buffercount:=0; { use bottom }
       if not logreadsec(trk,side,sec) then begin
              clreol;
              writeln(chr(7),'Warning, bad directory sector.');
              clreol;
              writeln('Press <space> to abort.');
              ch3:=readkey;
              if ch3=' ' then exit;
       end;
       move(buffer^[0],directory[i*x],y);
       advance(trk,side,sec);
  end;
  for i:=0 to maxdirs do
      a[i]:= addr(directory[i]);
end; { readdir }


procedure makealloc;
var i,j,sum,x : integer;
begin
   for i:=0 to 1023 do alloc[i]:=false; { mark as unused }
   for i:=0 to numblk do alloc[i]:=true; { mark directory area }
   for i:=0 to numdir do begin
     with a[i]^ do begin
    { read off blocks used for this entry }
      if key[0] <> $e5 then begin
         if blkaddrbyte then for j:=0 to 15 do alloc[block[j]]:=true
         else { use as words } for j:=0 to 7 do begin
            x:=block[2*j] + ( block[(2*j) +1] shl 8);
            alloc[x]:=true;
         end;
      end;
    end; { with }
   end; { for i }
   sum:=0;
   for i:=0 to numdir do if alloc[i] then sum:=sum+1;
   freespace:=totalspace-sum*kperblk;
end; { makealloc }

{xx $I quickdir.inc }

{ quick sort routines }
{ faster since eliminated set operations in [  ] checking }
{ got a bug hanging up somewhere on some directories }
{ the directory is read once, and then sorted }
{ This takes some time initially but it }
{ does facilitate later directory searches }
{ since the file entries are sorted by user number, }
{ name.ext and the extent byte. Thus all extents of a }
{ file appear in consective fcbs, pointed to by a[i + k]}
{ if a[i] points to the first fcb }

{ want to use pointers to sort, instead of moving the whole }
{ directory block }

{ compare }

function compare( x,y : fcb1ptr) : boolean;
{ returns true if directory[x].key < directory[y].key }
var i,j,k,u,v : integer;
    same : boolean ;
begin
compare:=false;
      if ( x^[0]= $e5)  and ( y^[0]= $e5 ) then exit;
      { early cutout for lots of blank comparisons }
    i:=-1;
    repeat
       i:=i+1;
       u:=x^[i];
       v:=y^[i];
    until (i >= 12 ) or (u <> v);
    compare:=(u < v) ;
end; { compare }


function limit( x,hi,lo : integer) : boolean;
{ return true is  lo <= x <= hi }
begin
  limit:=true;
  if x > hi then begin limit:=false;exit;end;
  if x < lo then begin limit:=false;exit;end;
end;  { limit }

{  index, item declared externally }
{  pointer version }

procedure quicksort1(n : integer); { programm 2.11, p.80 of Wirth }
const
   m = 100;
var
   i,j,l,r,over : integer;
   x,w : cpmdirptr;
   z,t : fcb1ptr;
   s : 0..m;
   stack : array[1..m] of record l,r : integer end;

begin
   s:=1;
   stack[1].l:=0;
   stack[1].r:=n;
   repeat { take top request from stack until s = 0 }
      l:=stack[s].l;
      r:=stack[s].r;
      if checkabort then begin exit end;
      s:=s-1;
      repeat { split a[l]..a[r] }
          i:=l;
          j:=r;
          x:=a[(l+r) div 2];
          z:=addr(x^.key);
          repeat      { until i > j }
             { find first  larger entry }
             while limit(i,n,0)  do begin
                  if compare(addr(a[i]^ ) ,z) then
                        i:=i+1
                    else begin
                        over:=i;
                        i:=-1;
                    end;
             end; { while }
             { then find  }
             if i=-1 then i:=over;
             while limit(j,n,0) do begin
                    if compare(z,addr(a[j]^)) then j:=j-1
                    else  begin
                       over:=j;
                       j:=-1;
                    end;
             end; { while }
             if j=-1 then j:=over;
             if i <=j then begin
                w:=a[i];
                a[i]:=a[j];
                a[j]:=w;
                i:=i+1;
                j:=j-1;
             end
          until i > j;
          {stack request to sort right partition }
          if j-l < r-i then begin
              if i < r then begin
                  s:=s+1;
                  stack[s].l:=i;
                  stack[s].r:=r;
              end;
              r:=j;
         end else begin
             if  l < j then begin
                 s:=s+1;
                 stack[s].l:=l;
                 stack[s].r:=j
             end;
             l:=i;
      end until l >= r
until s = 0
end; { quicksort1 }

procedure sortdir;
var i,j : integer;
begin
   quicksort1(mylabel.dpb.drm);
end; { sortdir }

procedure clearbottom;
begin
   gotoxy(1,22);clreol;gotoxy(1,23);clreol;gotoxy(1,24);clreol;
   gotoxy(1,25);clreol;
   gotoxy(1,22);
end; { clearbottom }


{xx $I logdsk.inc }



procedure getdefault(n:integer);
var  ch : char;
begin
   write(chr(7));
   clrscr;
   gotoxy(1,4);
   writeln('Non-Heath disk or corrupted label');
   writeln('The checksum is ',n,' instead of 0.');
   writeln('This login aborted. Try again with G or O options.');
   gotoxy(1,8);
end; { getdefault }

procedure writefirst;
var x : byte;
    kk : integer;
begin
   clearbottom;
   getdrive;
   insertdisk;
   if not firstread then begin
        writeln('Cannot read track 0, side 0, sector 1');
        havelogged:=false;
        writeln('This disk access aborted.');
        exit;
   end else begin
       writeln('Writing sector 1 of track 0 to DEBUG.BIN');
       assign(debugfile,'DEBUG.BIN');
       rewrite(debugfile);
       for kk:=0 to 2047 do begin
         x:=buffer^[kk];
         write(debugfile,x);
       end;
       close(debugfile);
       delay(1000);
   end;
end; { writefirst }

function log : boolean;
{ reads first sector, checks for valid heath label }
{ sets default parameters for subsequent reads and writes until next }
{ log  }
var ch : char;
    z  : ^heathlabel;
    n  : byte;
    good : boolean;
    x,y,uz,jjj : integer; { for var calls }
    SIDEFLAG : INTEGER;
    isetx,alreadycpm : boolean;
    sss: string[64];
begin
   alreadycpm:=false;
   ismorrow:=false;
   if not firstread then begin
        writeln('Cannot read track 0, side 0, sector 1');
        havelogged:=false;
        log:=false;
        writeln('This disk access aborted.');
        exit;
   end ;
   n:=chklabel(addr(buffer^[0]));
   if n = 0  then begin
      z:= addr(buffer^[0]);
      setlabel(z^);  { copy label, set global variables }
      havelogged:=true;  log:=true;
   end;
   if n <> 0 then begin
      n:=ckmorrow(addr(buffer^[137]));
      (* assume MORROW CP/M if bad label, but go ahead and check   *)
      (* for MORROW label in second 128 byte sector *)
      if n <> 0 then begin
         writeln;
         writeln('Not a MORROW CP/M disk.');
         writeln('Check drive specification again.');
         writeln;delay(1000);
         log:=false;
         havelogged:=false;
      end else { is valid morrow, so convert to Heath label } begin
            ismorrow:=true;
            sectorskew:=3; { crazy skew for soft sectored! }
            havelogged:=true;  log:=true;
            if (4 and buffer^[129]) = 0 then begin
            { is single sided morrow }
               setlabel(morrowss);
               writeln('Single Sided Morrow CP/M disk.');
               delay(1000);
            end
         else begin
              setlabel(morrowds);
               writeln('Double Sided Morrow CP/M disk.');
               delay(1000);
            end
      end; { now is heath type label }
    end; { if n <> 0 }
    if havelogged then begin
        readdir;
        sortdir;
        makealloc;
   end;
end; { log }

procedure login;
{ gets drive letter}
{ calls log to do work }
begin
   clearbottom;
   getdrive;
   insertdisk;
   if not log then begin
      writeln;
      clreol;
      writeln(#$07,'Can''t log this disk.');
      delay(medium);
   end;
end; { login }

procedure preserve;
{ copy the pointer to the standard floppy parameters }
{ save it for restoration when needed on exit, or when}
{ reading or writing to DOS drives }
{ copy most for our new params }

begin
   getparmptr(oldROMparms);
   myROMparams:=oldROMparms^; { use theirs }
end; { preserve }

function fcompar( x,y : fcb1ptr) : integer;
label 1222;
{ returns 1 if true if directory[x].key < directory[y].key }
{ 0 if = }
{ -1 if greater }
{ eventually allow for ? character, but not yet }
var i,j,u,v : integer;
    same : boolean ;
begin
      u:=x^[0]; v:=y^[0]; fcompar:=0;
      if ( x^[0]= $e5)  and ( y^[0]= $e5 ) then goto 1222;
      { early cutout for lots of blank comparisons }
      for i:= 0 to 11 do begin  { don't use extent for now }
         u:=x^[i] and $7f;
         v:=y^[i] and $7f;
         if u <> v then goto 1222;
      end;
      fcompar:=0;
 1222:
    if (u < v) then fcompar:=1 else if (u > v) then fcompar:=-1 ;
end; { compare }

procedure cleanitup( var x : nstring);
{ make x a suitable name for a cp/m file}
var i : integer;
    dummy : nstring;
begin
  dummy:='';
  for i:=1 to length(x) do begin
       x[i]:=upcase(x[i]);
       if not ( x[i] in illegal ) then dummy:=dummy+x[i];
  end;
  x:=dummy;
end; { cleanitup }

function spruce ( var x : nstring ) : nstring;
var i,j : integer;
    user : string[5];
    name : nstring;
    extt : nstring;
    blank :nstring;
    code,u : integer;
begin
    cleanitup(x);
    blank:='             ';
    j:=pos(':',x);
    if j = 0 then user:='0' else begin
        user:=copy(x,1,j-1); { oophs, forgot about high user numbers }
    end;
    name:=copy(x,j+1,255);
    j:=pos('.',name);
    if j = 0 then extt:='   ' else extt:=copy(name,j+1,255);
    if j >=2   then name:=copy(name,1,j-1) else name:='        ';
    extt:=extt+blank; name:=name+blank;
    if length(extt) > 3 then extt:=copy(extt,1,3);
    if length(name) > 8 then name:=copy(name,1,8);
    val(user,u,code);if code <> 0 then u:=0; { just to know what it does }
    { expand ambiguous file names to ????? }
    j:=pos('*',name);
    if j > 0 then begin
       name:=copy(name,1,j-1)+'????????';
       name:=copy(name,1,8);
    end;
    j:=pos('*',extt);
    if j>0 then begin
       extt:=copy(extt,1,j-1) + '????';
       extt:=copy(extt,1,3);
    end;
    spruce:= chr(u) + name + extt;
 end; { spruce }

function firstfile( var x : fcb1ptr): integer;
var i,j,which : integer;
    y : fcb1ptr;
begin
   firstfile:=-1;
   i:=0;
   repeat
     y:=addr(a[i]^);
     { do binary search ? }
     which:=fcompar(x,y);
     i:=i+1
   until (which >= 0) or (i > numdir); { cuts off if >= y }
   if (y^[0] <> $e5) and (which = 0) then begin
        if y^[0] <> $e5 then firstfile:=i-1;
    end else firstfile:=-1;
end; { firstfile }

function getdir(filename : nstring ) : integer;
var
    paddedname : nstring;
    filex : nstring;
    x : fcb1ptr;
 begin
   paddedname:= spruce(filename);
   { put user number in first byte, space out name to 8 + 3 }
   x:=addr(paddedname[1]);
   getdir:=firstfile(x);
end; { getdir }

function findnext( mydir  : integer) : integer;
{ finds next entry matching the dir pointer a[mydir] }
var x,y : fcb1ptr;
    i,which,j : integer;
begin
  findnext:=-1; { pessimist }
  if mydir >=0 then begin
     i:=mydir +1; { go one past it }
     x:=addr(a[mydir]^);
      { info to match }
     repeat
        y:=addr(a[i]^);
        which:=fcompar(x,y);
        i:=i+1
     until (which >= 0) or (i > numdir); { cuts off if >= y }
     if (y^[0] <> $e5) and (which = 0) then
       findnext:=i-1
    else findnext:=-1;
end; { if bad currentdir }
end; { findnext }


{ next function returns size of file, if a[mydir] points to cpmdir }
{ with the name of the file }

function sizeit( mydir : integer) : integer;
var size,last,more,counter,i : integer;
    x : cpmdir;
begin
if mydir<> -1 then begin { OK, FIND THE REST OF THE FILE }
    extent[0]:=mydir;
    counter:=1;
    repeat
      mydir:=findnext(mydir);
      extent[counter]:=mydir;
      counter:=counter+1;
    until mydir < 0;
    { if only one entry,counter=2,
    { now calculate file size }
    { get the extent byte on the last one }
    if counter >= 2 then more:=counter-2;
    if counter <=1 then more:=0;
    x:=a[extent[more]]^;
         { back one for the  i+1, back one for going past }
    last:= x.key[12];
    size:=16*(last) ;
    { now add on the sector count of partial extent }
    size:=size + (x.many div 8);
    if (x.many mod 8) <> 0 then size:=size + 1;
    sizeit:=size;
end else sizeit:=0;
end; { sizeit }

{xx $I cpmblk.inc}

type
     tristate = integer; { 1=true, 0=false, -1=abort }

var panic : integer;

procedure viewblock(n : integer ; prntflag : boolean);
{ expands tabs }
var i,trak,side,sect,tabcount : integer;
    ch : char;
begin
    if panic <=0 then exit;
    buffercount:=0;
    tabcount:=0;
if (n <= mylabel.dpb.dsm)  then begin
    alloc2trksec(n,trak,side,sect);
    convert(trak,side,sect);

    { read a allocation block }
    for i:=0 to phys2alloc-1 do begin
       if logreadsec(trak,side,sect) then begin end
       else begin
            clreol;writeln(chr(7),'Bad sector.');
            clreol;write('Press <space> to abort.');
            ch:=readkey;
            if ch=' ' then exit;
       end;
       buffercount:=buffercount+phys[secsize];
       advance(trak,side,sect);
    end;

    { list an allocation block }
    for i:=0 to (sizealloc -1) do begin
         { check keyboard }
         if checkabort then begin
            panic:=-1;
            gotoxy(1,25);
            clreol;
            writeln('User abort.');
            exit;
         end;
         ch:=chr(buffer^[i]);

         { the end of file test below does not check for physical eof }
         { if a text file is an exact multiple of 128, it may not have a $1A }

         case ch of
         #$0a,#$0a : begin
                       tabcount:=0;
                       write(ch); if prntflag then write(lst,ch);
                      end;
         #$1A       : begin
                         panic:=0;
                         exit;
                      end;
         #$0d,#$0A  : begin
                        tabcount:=0;
                        write(ch); if prntflag then write(lst,ch);
                      end;
          #$09       :begin
                         write(copy('          ',1, 8 - (tabcount mod 8)));
                         if prntflag then
                             write(lst,copy('          ',1, 8 - (tabcount mod 8)));

                         tabcount:=0;
                      end;
                      else begin
                         tabcount:=(tabcount+1) mod 8;
                         write(ch);if prntflag then write(lst,ch);
                      end;
           end; { case }
     end; { for }
 end;  { if n <= }
end; {viewblock }


procedure view(n : integer; prntflag : boolean);
var i,j,k,currblk,lastextent,nextdir : integer;
    fileblks : array[0..1023] of integer;  { allow up to 1024 blocks per file }
    finish : tristate;
    lastsectors : integer;
begin
 panic:=1; { ok so far }
 currblk:=0;
 for i:=0 to 1023 do fileblks[i]:=0; { initialize it }
    i:=n;
    if n >= 0 then begin
       repeat { find all extents }
          nextdir:=findnext(i); { check for later extents }
          i:=i+1;               { bump it }
       until nextdir = -1; { go until find last entry }
       { so last valid entry is n, or i-1 }
       lastextent:=max(n,i-1); { last good entry }
       writeln;
       for j:=n to lastextent do begin { extract file blocks from directory }
           if blkaddrbyte then begin   { uses bytes for alloc. block address }
             for k:=0 to 15 do begin
               fileblks[currblk]:=a[j]^.block[k];
               if fileblks[currblk] <> 0 then currblk:=currblk+1;
              { if it was a 0, then write over it next time }
           end  { for }
          end { if word block numbering  } else
           for k:=0 to 7 do begin
               fileblks[currblk]:= a[j]^.block[2*k] + (a[j]^.block[1+2*k] shl 8);
               if fileblks[currblk] <> 0 then currblk:=currblk+1;
           end; { else for }
     end; { for j }
     currblk:=currblk-1;
     lastsectors:=a[lastextent]^.many;
     { number of 128 byte sectors in last 16k  extent }
     { ok, got all the allocation numbers now }
     { have to translate these into physical sectors and do the reads }
     for k:=0 to currblk do
       viewblock(fileblks[k],prntflag);
       if  panic<=0  then begin delay(medium);exit;end;
  end; { if n >= 0 }
  delay(long);
end; { view }

function  copyblock(n: integer ; var dosfile : FILE ; thismany : integer) : boolean ;
{ expands tabs }

var i,trak,side,sect,tabcount : integer;
    ch : char;
begin
    buffercount:=0;
    tabcount:=0;
    copyblock:=false;
if n <= mylabel.dpb.dsm then begin
    alloc2trksec(n,trak,side,sect);
    convert(trak,side,sect);
    for i:=0 to phys2alloc-1 do begin
       if logreadsec(trak,side,sect) then begin end
       else begin
          clreol;writeln(chr(7),'Bad MORROW CP/M sector.');
          clreol;write('Press <space> to abort.');
          ch:=readkey;
          if ch=' ' then begin
             copyblock:=true;   { say we're through }
             exit;
          end;
       end;
       buffercount:=buffercount+phys[secsize];
       advance(trak,side,sect);
    end;
    blockwrite(dosfile,buffer^[0],thismany)
 end;
end; {copyblock }


procedure copycpm(var dosfile : file ; n : integer);
{ this cheats and rounds up to an allocation unit on the CP/M file }
{ try to get around the cheating }
label 2222;
var i,j,k,currblk,lastextent,nextdir : integer;
    fileblks : array[0..1023] of integer;  { allow up to 1024 blocks per file }
    finish : boolean;
    lastsectors,extra,cpm2blk : integer;
begin
     currblk:=0;
     for i:=0 to 1023 do fileblks[i]:=0; { initialize it }
     i:=n;
     if n >= 0 then begin
        repeat { find all extents }
          nextdir:=findnext(i); { check for later extents }
          i:=i+1;               { bump it }
        until nextdir = -1; { go until find last entry }
        { so last valid entry is n, or i-1 }
        lastextent:=max(n,i-1); { last good entry }
        for j:=n to lastextent do begin { extract file blocks from directory }
           if blkaddrbyte then begin   { uses bytes for alloc. block address }
              for k:=0 to 15 do begin
                  fileblks[currblk]:=a[j]^.block[k];
                  if fileblks[currblk] <> 0 then currblk:=currblk+1;
                  { if it was a 0, then write over it next time }
              end  { for }
           end { if word block numbering  } else
           for k:=0 to 7 do begin
              fileblks[currblk]:= a[j]^.block[2*k] + (a[j]^.block[1+2*k] shl 8);
              if fileblks[currblk] <> 0 then currblk:=currblk+1;
           end; { else for }
        end; { for j }
       currblk:=currblk-1;
       lastsectors:=a[lastextent]^.many;
       { number of 128 byte sectors in last 16k  extent }
       { ok, got all the allocation numbers now }
       { have to translate these into physical sectors and do the reads }
       cpm2blk:=(mylabel.dpb.blm + 1);
       extra:= lastsectors mod  cpm2blk;
       { is there part of a allocation block not used? }
       for k:=0 to (currblk - 1)  do begin
           finish:= copyblock(fileblks[k],dosfile,cpm2blk);
           if finish then goto 2222;
       end;
       { now copy the last few sectors }
       if extra=0 then extra:=cpm2blk;
       finish:=copyblock(fileblks[currblk],dosfile,extra);
  end; { if n >= 0 }
 2222:
     close(dosfile);
end; { copycpm }

procedure mklegal(var x : nstring);
{make legal by eliminating illegal characters from names }
var i : integer;
    y : char;
begin
  for i:=1 to length(x) do begin
  { problem: can't find list of allowable dos characters for filenames }
     case x[i] of
       '/' : y:='-';
       '\' : y:='-';
       '+' : y:='-';
       else  y:=x[i];
     end; { case }
     x[i]:=y;
  end; { begin do }
end; { mklegal }

function mkdosname( root : nstring; name : nstring; var dosfile : FILE ): boolean;
var myio:integer;
begin
      mkdosname:=true; { assume good name }
      mklegal(name);
      if root[length(root)]<> ':' then root:=root+'\';
      name:=root+copy(name,pos(':',name)+1,255);
      writeln(name);
      assign(dosfile,name);
      {$I-}
      rewrite(dosfile); myio:=ioresult;
      {$I+}
     if myio <> 0 then begin
        writeln(#$07,'Invalid DOS file.');
        mkdosname:=false;
        {$I-}
        close(dosfile);
        {$I+}
     end;
end; { mkdosname }


{ make a list of the irredundant directory entries, so can back up, etc }

type
      dirtag = record
                 place : integer;
                 tag   : char;
               end;
var
     thisdir : array[0..2047] of dirtag;

function mklast: integer; { make a list of last extents, with a tag }
var i,j : integer;
begin
   for i:=0 to 2047 do begin
         thisdir[i].place:=-1;
         thisdir[i].tag:=' ';
   end;
   i:=0; j:=0;
   repeat
    if findnext(i)=-1 then begin
       thisdir[j].place:=i;
       j:=j+1;
       i:=i+1;
    end else i:=i+1;
    until (i > mylabel.dpb.drm) or (a[i]^.key[0]=$e5);
    if j>1 then j:=j-1 else j:=0;
    mklast:=j;
end; { mklast}


procedure dir2name( var dummy : nstring ; i : integer);
var j : integer;
    ch : char;
begin
   with a[i]^ do begin
       str(key[0]:2,dummy);
       dummy:=dummy+':' ;
       for j:=1 to 8 do begin
           ch:=chr(key[j] and $7f);
           if ch <> ' ' then dummy:=dummy+ch;
       end;
       dummy:=dummy+'.';
       for j:=9 to 11 do begin
           ch:=chr(key[j] and $7f);
           if ch <> ' ' then dummy:=dummy+ch;
       end; { for }
   end; { with }
end; { dir2name }


procedure masscopy(last : integer);
var root : nstring;
    i,n : integer;
    dosfile : FILE;
    dummy : nstring;
begin
   gotoxy(1,24);clreol;
   gotoxy(1,25);clreol;
   write('Dos directory?  ');
   readln(root);
   i:=0;
   repeat
     if thisdir[i].tag='T' then begin
       dir2name(dummy,thisdir[i].place);
       gotoxy(1,24);
       clreol;
       write('Copying   ',dummy, ' to ');
       n:=getdir(dummy);
       { points to first directory entry for file }
       if mkdosname(root,dummy,dosfile) then copycpm(dosfile,n);
      end; { if }
      i:=i+1;
   until checkabort or (i > last);
end; { masscopy }

const
 s1: nstring ='ŠŠŠéÅÚÓØÃÍÂÞŠž…›š…›“’’ŠŠéÆËØÏÄÉÏŠý„ŠýÃÆÁÏØÙÅĆŠàØ„';
 s2: nstring ='ŠŠŠëÆÆŠøÃÍÂÞÙŠØÏÙÏØÜÏΊŠæÃÉÏÄÙÏΊÞÅŠà„ë„ŠèÏÄÞØßÚ';
 s3: nstring ='ŠŠŠØÈËĈŠãÆÆÃÄÅÃÙŠŠŠŠŠœ›’š›';


procedure writedecode(code : byte; s : nstring);
var ii : integer;
begin
for ii:=1 to length(s) do  write(chr(ord(s[ii]) xor code));
end;

procedure help76;

begin
  clrscr;
  writeln('   MORROW CP/M File Transfer to MS-DOS ');
  writeln;
  writedecode($aa,s1);writeln;
  writedecode($aa,s2);writeln;
  writedecode($aa,s3);writeln;
  gotoxy(1,7);
  writeln('           File Transfer Commands ');
  writeln(' T - tag for copy          U - untag for copy');
  writeln(' V - view on screen        P - send to list device');
  writeln(' W - mass tag or untag     M - do mass copy of tagged files');
  writeln(' B - move back 1 file      ? - show this help screen');
  writeln(' L - log new disk          X - or Z or Q  back to DOS');
  write  (' S - skew factor ',sectorskew:2);
  writeln('        D - dump to DOS file DEBUG.BIN');
  writeln;
  writeln('User    Name          Size       Tagged Size');
  gotoxy(1,25);clreol;
  gotoxy(1,16);
  if not havelogged then begin
       clreol;
       writeln('No MORROW CP/M disk logged yet.');
  end;
end; { help76 }

procedure firstscreen(k : integer);
var  dummy : nstring;
     i, m : integer;
{fill the screen below line 16 with directory entries, and come back to 15 }
begin
if havelogged then begin
  for m:=0 to 8 do begin
           i:=thisdir[k].place;
           k:=k+1;
           if i <> -1 then begin
              dir2name(dummy,i);
              dummy:=dummy + '                           ';
              dummy:=copy(dummy,1,20);
              writeln(dummy,sizeit(i):6,'k   ',thisdir[k].tag);
           end;
  end; { m }
  gotoxy(1,16);
end; { if have logged }
end; { firstscreen }

procedure tagdir;
var n,i,j,k,l,alldone,last : integer;
    ch : char;
    dummy,root: nstring;
    tagged : integer;

procedure update;
{ display total of tagged files }
var m : integer;
begin
  tagged:=0;
  for m:=0 to last do
     if (thisdir[m].place <> -1)  and  (thisdir[m].tag = 'T' )   then
         tagged:=tagged + sizeit(thisdir[m].place);
end; { update }


begin
       help76;
       k:=0;
       last:=mklast; { get last extents }
       firstscreen(k);
       tagged:=0;
       repeat  { until i> mylabel.dpb.drm }
        if havelogged then begin
           i:=thisdir[k].place;
           if i <> -1 then begin
              dir2name(dummy,i);
              dummy:=dummy + '                           ';
              dummy:=copy(dummy,1,20);
              clreol;
              write(dummy,sizeit(i):6,'k   ',thisdir[k].tag,tagged:6,'k');
            end;  { if <> $E5 }
            { wait for <CR>, 'T', }
        end; { if havelogged }
        { check for function keys, etc here }
        ch:=readkey;
             ch:=upcase(ch);
             { LOCK OUT all options except L,G if have not logged disk yet }
              if ch= #0 then  begin{ special key }
                  ch:=readkey; { get next char }
                  case ch of   { change for tp4.0 }
                      #$48 : { up arrow} ch:='B';
                      #$50 : { down arrow} ch:=#$0d;
                      #$49 : { up page } ch:=  'F';
                      #$51 : { down page} ch:= 'D';
                   else ch:=#$0d;
               end; { case of special keys }
             end; { if special }

                 case ch of

                 #27 : begin
                         ch:=readkey;
                         { gobble next char also }
                          writeln;
                        end;

                 #$0d,' ' : begin
                          if havelogged then begin
                             writeln;
                             k:=k+1;
                          end;
                        end;

                 'T',#09  :  begin
                      if havelogged then begin
                           write(' T');
                           thisdir[k].tag:='T';
                           k:=k+1;
                           update;writeln;
                       end; { if havelogged }
                   end;

                 { put in other Disk76 commands }
                 'L' : begin
                          login;
                          help76;
                          last:=mklast;
                          tagged:=0;
                          k:=0;
                          firstscreen(k);
                       end;
                 'K' : begin
                          writefirst;
                          help76;
                          last:=mklast;
                          tagged:=0;
                          k:=0;
                          firstscreen(k);
                        end;
                 'S'   : begin
                           clearbottom;
                           write('Define new skew factor: ');
                           readln(sectorskew);
                           delay(1000);
                           help76;
                           last:=mklast;
                           tagged:=0;
                           k:=0;
                           firstscreen(k);
                         end;{ set skew factor }
                 'U'   : begin  { untag }
                           if havelogged then begin
                             thisdir[k].tag:=' ';
                              k:=k+1;
                              update;
                              writeln;
                           end; { if havelogged }
                         end;

                 'B',#08   : begin  { backwards }
                       if havelogged then begin
                         k:=k-1;
                         if k < 0 then k:=last;
                         writeln;
                       end; { if havelogged }
                         end;
                 'D'   : begin  { down page }
                           if havelogged then begin
                              k:=k+8;
                              if k >last then k:=0;
                              help76;
                              firstscreen(k);
                           end; { if havelogged }
                     end;
                 'F'   : begin  { down page }
                           if havelogged then begin
                              k:=k-8;
                              if k < 0 then k:=0;
                              help76;
                              firstscreen(k);
                         end; { if havelogged }
                      end;

                 'V'   : begin  { view on console}
                           if havelogged then begin
                              dir2name(dummy,thisdir[k].place);
                              n:=getdir(dummy);
                              clrscr;gotoxy(1,15);
                              view(n,false);
                              help76;
                              firstscreen(k);
                           end; { if havelogged }
                         end;

                 'P'   : begin  { print to list device }
                         if havelogged then begin
                           dir2name(dummy,thisdir[k].place);
                           n:=getdir(dummy);
                           clrscr;gotoxy(1,15);
                           view(n,true);
                           help76;
                           firstscreen(k);
                         end; { if havelogged }
                         end;

                 'M','C'   : begin  { masscopy }
                         if havelogged then begin
                           masscopy(last);
                           help76;
                           firstscreen(k);
                         end; { if havelogged }
                         end;  { start copy now }

                 'W'    : begin   { wildcard tag-untag }
                          if havelogged then begin
                            gotoxy(1,24);
                            clreol;gotoxy(1,25);clreol;
                            write('Tag or Untag <U,T>? ');
                            readln(ch);ch:=upcase(ch);
                            if ch='T' then for l:=k to last do
                               thisdir[l].tag:='T';
                            if ch='U' then for l:=k to last do
                                thisdir[l].tag:=' ';
                            help76;
                            firstscreen(k);
                            update;
                           end; { if havelogged }
                          end; { w }
                 '?','H' : begin
                          help76;
                          firstscreen(k);
                        end;

                 'Q','X','Z' : begin   { abort }
                                gotoxy(1,25);clreol;
                                write('Return to DOS? ');
                                ch:=readkey;
                                write(ch);ch:=upcase(ch);
                                if ch='Y' then alldone:=$e5;
                               end;
                  else begin
                            if havelogged then begin
                                writeln;
                                k:=k+1;
                            end;
                  end;{ if ch not T or CR, reshow entry }
              end; { case }
          if i=-1 then k:=0; { start over }
       until (alldone=$e5);
 end;  { tag dir }

{xx $I dmachk.inc}

{ hardware problem on the PC DMA: can't cross 64k boundary }
{ the rom bios apparently doesn't correct for this }

function ok( var x: buffertype ; n : word) : boolean;
{ checks to see if x^[0]....x^[buffersize] cross a 64k boundary }
var  xseg, xofs : word;
     ybeg, yend : longint;
begin
    xseg:=seg(x[0]);
    xofs:=ofs(x[0]);
    ybeg:=16*xseg + xofs;
    yend:=ybeg + n*sizeof(x[1]);
    ybeg:=ybeg shr 16;
    yend:=yend shr 16;
    if yend = ybeg then ok:=true else ok:=false;
end; { ok }

function allocbuffer : boolean;
var   x : bufferptr;
begin
   write('Allocating buffer space ');
   allocbuffer:=false; { pessimist }
   repeat
      new(x);
      write('*');
   until (x=nil) or ok(x^,buffersize);
   if x<> nil then begin
          allocbuffer:=true;
          buffer:=x;
   end;
   writeln;
end;   { allocbuffer }

{xx $I logo.inc}

procedure logo;
begin
     clrscr;
     gotoxy(1,12);writeln('MORROW CP/M FILE TRANSFER to MS-DOS FILES');
     delay(1000);
     clrscr;
     writeln('Copyright, 4-10-88 by Clarence W. Wilkerson, Jr.');
     writeln('All rights reserved.');
     writeln;
     writeln('This  program transfers files from MORROW CP/M  double');
     writeln('density 5.25 inch disks to MS-DOS files. It requires the use ');
     writeln('of an IBM-PC compatible computer, since disk access is done ');
     writeln('with ROM BIOS calls.');
     writeln;
     writeln('In case of abnormal termination, reboot the system.');
     writeln;
     delay(2000);
end; { logo }


procedure getcmmnd( var s : nstring);
{  save the initial command line for later analysis }
begin
    { MSDOS Turbo 3.x has built-in command line parsing }
    { do this way so can be changed for other OS and turbo versions }
    if paramcount > 0 then s:=paramstr(1) { ignore rest }
    else s:=''; { no parameters }
end; { getcmmnd }
var ch5 : char;

begin  { main }
    checkbreak:=false; { readkey returns #3 for ctl-break }
    getcmmnd(cmmdline);
    logo;
    if not allocbuffer then begin
       writeln(#$07);
       writeln('Can not allocate buffer space missing 64k boundary.');
       writeln('Aborting program.');
       halt;
    end;
    preserve; { save present disk environment }
    ismorrow:=false;
    sectorskew:=0; { ammount to be added to get next physical sector}
    havelogged := false; { don't allow any operations until.. }
    log2phys:=8;
    activefilename:='NoName.Yet';
    initdefault;
    if length(cmmdline) > 0 then begin
        ch5:=upcase(cmmdline[1]);
        { decide drive number, load it in ?? }
        drivenumber:=ord(ch5)-ord('A');
        if limit(drivenumber,3,0) then if not log then login;
   end;
   if not havelogged then login;
   tagdir;
   smoothexit; { reset disk parameters }
 end.