{$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+}

(* adapted from previous readcpm by CWW *)
(* so lots of bells and whistles *)
(* first hack has constants hardwired in *)
(* COCO RSDOS disk has 35 tracks, one side, 18 sectors of *)
(* 256 bytes each *)
(* allocation blocks are called granules, and each granule *)
(* uses 9 physical sectors *)
(* there are 2 granules per track, except for track 17 which *)
(* is reserved for directory and fat table *)
(* RSDOS seems to try to optimize write close to track 17 *)
(* the FAT table is similar to MSDOS, with 1 byte FAT pointers *)
(* $FF means a free granule, and ordinary pointers go from *)
(* 0 -> 67. Pointers $C0 ->C8 mean it's the last granule of a file *)
(* and that  1-9 sectors  are used. *)
(* the directory structure is 32 bytes long, with 16 bytes unused *)
(* 0-11 is file name, with byte 0 = 0 for erased, and FF for unused *)
(* the assumption is that no more directory entries after the first *)
(* FF. The first fat pointer is in the directory entry, ala MSDOS. *)
(* However, the file size is only given indirectly: *)
(* the number of bytes in the last sector used is in the entry *)
(* Thus to find the file size, one steps down fat chain til $CX *)
(* entry. Have 9*(k-1)*256 bytes so far, + X* 256 + size from *)
(* directory entry *)


program read_write_coco;

(* TP4.0 version *)

Uses
  Crt,
  Dos,
  Printer;

{$I cocovars.inc}

procedure sorry;
begin
   gotoxy(1,messageline);clreol;
   write('Sorry, have to login the COCO disk first.');
end; { sorry }

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

procedure insertdisk;
begin
  writeln;
  writeln('Insert diskette in drive ',chr(65+drivenumber),':  and press <CR>');
  readln;
end; { insertdisk }


procedure errmessage( n : integer; s : nstring);
begin
  gotoxy(1,messageline + n);
  clreol;
  write(s);
end;



procedure getdrivetypes; (* read CMOS and get floppy types *)
var x:byte;
begin
  port[clock]:=diskbyte;
  delay(1);
  x:=port[clock +1];
  drive0:= x  shr 4;
  drive1:= x and $0f;
 end; (* getdrivetypes *)

procedure ISTHISAT;
var x : byte;
begin
  x:=mem[$f000:$fffE];
  if x= $FC then ATflag:=true else ATflag:=false;
  if ATflag then getdrivetypes;
end;


(* display functions *)

procedure reverseCRT; (* toggle colors *)
begin
  textbackground(7);
  textcolor(0);
end;

procedure normalCRT;
begin
normvideo;
end;


{ 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 }


(* error messages and prompts *)

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
      #$1B,^C,^Z : checkabort:=true;

      #0    : begin
                ch:=readkey;
                checkabort:=true;
              end; (* function key cases *)

      ^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
  gotoxy(1,messageline);clreol;
  write('Procedure not yet implemented.');
end;

(* file name handling and translation *)

function getdosname(s: nstring ; var dosfile : FILE): boolean;
var
   name : nstring; { long path name }
   myio : integer;
begin
   getdosname:=false;
   repeat
      write(s);
      readln(dosname);
      assign(dosfile,dosname);
      {$I-}
      rewrite(dosfile,1); (* record size 1 *)
      myio:=ioresult;
      {$I+}
   until (myio = 0 ) or (dosname[1]=^Z);
   if myio=0 then getdosname:=true;

end; { getdosname }

function openwDOS(s: nstring ; var dosfile : text) : boolean;
{ open for writing text files }
var
   name : string[64]; { long path name }
   myio : integer;
begin
   openwdos:=false;
   repeat
      write(s);
      readln(dosname);
      assign(dosfile,dosname);
      {$I-}
      rewrite(dosfile); myio:=ioresult;
      {$I+}
   until (myio = 0) or (dosname[1]=^Z);
   if myio=0 then openwdos:=true;
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
      gotoxy(1,messageline);clreol;
      writeln('File read attempt aborted.');
      openrdos:=false;
   end;
end; { openrdos }

{xx $I ROMERR.INC }

procedure errormsg( x : byte);
begin
   gotoxy(1,messageline);
   clreol;
   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;
    delay(1000);
 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 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;

procedure putword( x : integer );
begin
   putbyte(hi(x));
   putbyte(lo(x));
end; { putword }

procedure putlong( x : longint); (* only puts 24 bits *)
{xx $I get.inc }
var y : longint;
    z:  integer;
    begin
  y:= x and $FFFF0000;
  z:= integer(y shr 16);
  putword(z);
  z:= x  and $0000FFFF;
  putword(z);
end;

var hex16count: integer;
    totalhex  : longint;
    hexbuf    : array[1..16] of byte;

procedure inithex;
var i : integer;
begin
 totalhex:=0;
 hex16count:=0;
end;

procedure putclean(x : byte);
begin
  x:= x and $7f;
  if x < 32 then write('.')
  else if x > 126 then write('.')
  else write(chr(x));
end; (* putclean *)

procedure sendhex( x : byteptr; count : integer ; marker : longint);
var jj : integer;
    y : byte16ptr;
begin
  if count=0 then exit;
  y:= addr( x^ );
  write('  ');
  putlong(marker and $FFFFF0);
  write('  ');
  for jj:=1 to 4 do putbyte(y^[jj]);
  write(' ');
  for jj:=5 to 8 do putbyte(y^[jj]);
  write(' ');
  for jj:=9 to 12 do putbyte(y^[jj]);
  write(' ');
  for jj:=13 to 16 do putbyte(y^[jj]);
  write('  # ');
  for jj:=1 to 16 do putclean(y^[jj]);
  writeln(' #');
end;

procedure sendouthexline;
var jj : integer;
begin
  if hex16count=0 then exit;
  write('  ');
  putlong(totalhex and $fFFFF0);
  write('  ');
  for jj:=1 to 4 do putbyte(hexbuf[jj]);
  write(' ');
  for jj:=5 to 8 do putbyte(hexbuf[jj]);
  write(' ');
  for jj:=9 to 12 do putbyte(hexbuf[jj]);
  write(' ');
  for jj:=13 to 16 do putbyte(hexbuf[jj]);
  write('  # ');
  for jj:=1 to 16 do putclean(hexbuf[jj]);
  writeln(' #');
  hex16count:=0;
end;


procedure gethex16( x : byte);
begin
  hex16count:=hex16count+1;
  hexbuf[hex16count]:=x;
  totalhex:=totalhex+1;
  if hex16count >= 16 then begin
     sendouthexline;
     hex16count:=0;
   end;
end;


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 y:=0 else
  begin
     y:=y shr 6;
     y:=y and 3;
     y:=y+1;
  end;
  if ATflag then getdrives:=min(2,y) else getdrives:=min(4,y);
end; { getdrives }

procedure getdrive;
var ch : char;
begin
  repeat
      gotoxy(1,messageline-2);
      clreol;
      write('Which drive for COCO disk? <A:>  ');
      ch:=readkey; writeln(ch);
      if ch = #$0d then ch:='A' else ch:=upcase(ch);
      drivenumber:=ord(ch) - ord('A');
      delay(200);
  until (ch in ['A'..'P']) and (drivenumber < 4 );
 end; { getdrive }

(* given a granule number, pokes proper track and sector and side *)
procedure granule2trksec(which : integer; var trak,side,sect : integer);
begin
    side:=0;
    if which  < 34 then begin
       trak:= which div 2;
       sect:= ( (which mod 2) * 9) +1;
    end
    else begin
       trak:= (which div 2) + 1;
       sect:= ((which  mod 2) * 9) +1;
    end;
end; { granule2trksec }

var drive0state, drive1state : byte;

procedure setdensity;
var x,y : byte;
begin
if ATflag then begin
  drive0state:=mem[$40:$90];
  drive1state:=mem[$40:$91];
  x:=drive0state;
  y:=drive1state;
  if not havelogged then begin (* assume 48 tpi *)
    if drive0 in [2..4] then x:= $70 or 4 else x:=$50 or 3;
    if drive1 in [2..4] then y:= $70 or 4 else y:=$50 or 3;
  end
  else (* believe the disk parameter header *)
  begin
    if drive0 in [2..4] then if is96tpi then   x:= $50 or 4 else x:=$70 or 3;
    if drive1 in [2..4] then if is96tpi then   y:= $50 or 4 else y:=$70 or 3;
  end;
end;
case drivenumber of
     0: mem[$40:$90]:=x;
     1: mem[$40:$91]:=y;
     else begin end;
   end; (* case *)
end; (* set density *)

procedure resetdensity;
begin
  if ATflag then begin
  case drivenumber of
    0 :   mem[$40:$90]:=drive0state;
    1 :   mem[$40:$91]:=drive1state;
  else begin end
  end; (* case *)
  end;
end; (* reset density on AT *)

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:= 18 ;
   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]);
   if ATflag then setdensity;
   intr(DISKIO,Dos.Registers(z));
   if ATflag then resetdensity;
   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 writesec(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:= 18 ;
   z.dl:= drivenumber;
   z.dh:= side;
   z.ch:= lo(trk);
   z.cl:= lo(sector);
   z.ah:= diskwrite ;
   z.al:= ONESECTOR;
   z.es:= seg(buffer^[buffercount]);
   z.bx:= ofs(buffer^[buffercount]);
   if ATflag then setdensity;
   intr(DISKIO,Dos.Registers(z));
   if ATflag then resetdensity;
   smooth;
end; { tryagain }

begin  { write }
 errcount:=MAXTRIES;
  repeat
   { switch to my parameters }
   setparmptr(addr(myROMparams)); { point to my table }
   writesec:=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);
      writesec:=false;
   end else writesec:=true;
end; { writesec read 1 physical sector }


function firstread  : boolean; { read absolute sector 0 }
{ tries to read sector 1 of track 0, side 0. If cannot read with }
{ sector size 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:=1 to 3  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
      gotoxy(1,messageline);clreol;
      writeln(phys[i],' bytes per sector.');

      delay(1000);
      firstread:=true;
      goto 123;
   end;
 end;
123:
     log2phys:= phys[secsize] div 128;
     smooth; { restore old parameters }
end; { firstread }


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


procedure smoothexit;
begin
  smooth;
  halt;
end;


(* hard wire the coco constants in here *)

(* reads coco fat table and directory *)


function readfat : boolean;
var k,trk,side,sec : integer;
    ch3 : char;
begin
   fillchar(cocofat[0],256,$f4);
   trk:=17;
   side:=0;
   sec:=2 ; (* cocofatbegin; *)
   secsize:=1 (* only for 256 byte disks *);
   if not readsec(trk,side,sec)  then begin
        errmessage( -1,'Warning, bad FAT sector.');
        readfat:=false;
   end
   else readfat:=true;
   move(buffer^[0],cocofat[0],$100);
end; (* read fat *)

procedure dumpfat;
var k,i : integer;
begin
    writeln('FAT table has 68 entries. ');
    writeln;
    k:=0;
    writeln('  0       4       8       C');
    for i:=0 to 67 do begin
      if i mod 16 = 0 then begin writeln(' ', i mod 16 : 2) ;clreol; end;
      if cocofat[i] <> $FF then write('X') else write('O');
    end;
    writeln;clreol;
    writeln;clreol;
    for k:=0 to 15 do sendhex(addr(cocofat[k*16]),16,k*16);
    presscrlf;
end; (* dump fat *)

procedure dumpdir;
var i : integer;
begin
writeln('Number of used directory entries is ',actualcocodirs + 1);
writeln;
  for i:=0 to actualcocodirs do begin   (* for debugging, check if right so far *)
    sendhex(addr(original[i]^),16,longint( i*32 ));
    sendhex(addr(original[i]^.res),16,longint ((i * 32) + 16));
  end;
  presscrlf;
end; (* dumpdir *)

function  readdir : integer;
(* returns number of directory entries, or -1 for error *)
var endflag,i,k,jjj,trk,side,sec,sectemp,x,y : integer;
    ch3 : char;
begin
   if not readfat then begin
       readdir:=-1;
       exit;
   end;
   fillchar(buffer^[0],buffersize,$F5);
   trk:=17;
   side:=0;
   secsize:=1 (* only for 256 byte disks *);
   (* directory is an array of COCOdirs *)
   fillchar(buffer^[0],buffersize,$F2);
   fillchar(directory[0],maxdirs*32,$F1); { blank it }
   sec:=3; (* cocodirbegin *)
   y:=256 ;{ phys[secsize];} { bytes per physical sector }
   x:=8; { coco directory entries per physical sector }
   for i:=0 to 8 do begin
       buffercount:=0; { use bottom }
       sectemp:=sec+i;
       (* writeln('reading sector ',sectemp,' of directory.'); *)
       if not readsec(trk,side,sectemp) then begin
              errmessage(-1,'Warning, bad directory sector.');
              write('Press <ESC> to abort.');
              ch3:=readkey;
              if ch3= #27 then begin
                 readdir:= -1;
                 exit;
              end;
       end;
       (* now load this sector's info into directory buffers *)
       for jjj:=0 to 7 do
           move( buffer^[jjj*32], directory[i*8 +jjj],32);
  end;
  for i:=0 to maxdirs do begin   (* set pointers *)
      a[i]:= addr(directory[i]);
      original[i]:=a[i];
  end;
  k:= -1;
  repeat     (* find last valid directory entry *)
    k:=k+1;
    endflag:=a[k]^.key[0];
  until ( endflag  = $ff) or ( k >= 71);
  k:=k-1;
  readdir:= k;
end; { readdir }


procedure markgranule;
var i,j,sum,x : integer;
begin
   sum:=0;
   for i:=0 to 67 do granulefree[i]:= false; { mark as used }
   for i:=0 to 67  do  begin
       granulefree[i]:= ( cocofat[i] = $ff);
       if granulefree[i] then sum:= sum + 1;
    end;
   freespace:=integer( (longint(sum) * longint(bytespergran)) div 1024) ;
end; { makegranule }

{ quick sort routines }
{ 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  }
{ name.ext }

{ 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]= $FF )  then exit;
      if ( x^[0] = 0 ) then exit;

      { early cutout for lots of blank comparisons }
    i:=-1;
    repeat
       i:=i+1;
       u:=x^[i];
       v:=y^[i];  (* starting at first symbol key[0] *)
    until (i >= 10 ) 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 : cocodirptr;
   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(actualcocodirs);
end; { sortdir }

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


{xx $I logdsk.inc }



procedure getdefault(n:integer);
var  ch : char;
begin
   write(chr(7));
   clrscr;
   gotoxy(1,messageline-2);clreol;
   write('Non-COCO disk. ');
   writeln('This login aborted. Try again with G or O options.');
   delay(2000);
   presscrlf;
end; { getdefault }


function log : boolean;
{ sets default parameters for subsequent reads and writes until next }
{ log  }
var ch : char;
    n  : byte;
    good : boolean;
    x,y,uz,jjj : integer; { for var calls }
    SIDEFLAG : INTEGER;
    isetx,alreadycoco : boolean;
    sss: string[64];
begin
   alreadycoco:=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;
   if secsize = 1 then begin
       havelogged:=true;
       log:=true;
   end
   else begin
         gotoxy(1,messageline-2);clreol;
         writeln('Not an COCO disk. Sector size wrong. Probably MS-DOS disk.');
         clreol;
         writeln('Check drive specification again.');
         presscrlf;
         log:=false;
         havelogged:=false;
    end;
    if havelogged then begin
        actualcocodirs:=readdir;
        if (actualcocodirs = -1) then begin
           havelogged:=false;
           log:=false;
           exit;
        end;
        sortdir;
        markgranule;
    end;
end; { log }

procedure login;
{ gets drive letter}
{ calls log to do work }
begin
   clearbottom;
   getdrive;
   insertdisk;
   if not log then begin
      gotoxy(1,messageline-2);
      clreol;
      write(#$07,'Can''t log this disk.');
      presscrlf;
      havelogged:=false;
   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]= $FF)  and ( y^[0]= $FF) then goto 1222;
      { early cutout for lots of blank comparisons }
      for i:= 0 to 10 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 coco 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] <> $FF) and (which = 0) then begin
        if y^[0] <> $FF 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] <> $FF) and (which = 0) then
       findnext:=i-1
    else findnext:=-1;
end; { if bad currentdir }
end; { findnext }



(* traverse the fat bytes to find granules used, and file size *)
(* uses lots of var parameters *)

procedure traverse( fileno : integer;
   var granule : granuletable; var full_granules : integer;
   var lastsectors : integer; var left_over : integer );
var k, last_full_granule, partial_granule : integer;
begin
{ uses bytes for granule pointers }
     (* writeln('in traverse file number ',fileno); *)
     granule[0]:= a[fileno]^.first;
     left_over:= swap(a[fileno]^.lastbytes ); (* was in 6809 byte order *)
     k:=0;
     while ( (granule[k] < 68) and ( k < 68 ) ) do begin
          last_full_granule:=granule[k];
          k:=k+1;
          granule[k]:= cocofat[last_full_granule];
     end;
     full_granules:= k-1;
     partial_granule:=granule[k];
     lastsectors:= (partial_granule and $0f) -1 ;
     (* so stops on $FF or $CX or k = 68 *)
     if ( partial_granule = $FF) or ( k >= 68) then begin
        writeln('Bad FAT table.');
        readln;
        exit;
     end;
end; (* traverse *)


procedure print_traverse( fileno : integer);
var granule : granuletable;
    last_full, last_sector,last_bytes,i,k : integer;
begin
 k:=0;
 clreol;writeln('Traversing file number ',fileno);
 fillchar(granule[0],68,$F7);
 traverse( fileno, granule, last_full, last_sector, last_bytes);
 for i:=0 to (last_full + 1) do begin
      if k mod 13 =0 then begin writeln; clreol end;
      putbyte(granule[i]);
      if ( granule[i] < 68 ) then write('->');
      k:=k+1;
  end;
  end; (* print_traverse *)

(* next function returns size of file, if a[mydir] points to cocodir *)
(* with the name of the file *)
(* should be changed to use traverse *)

function sizeit( fileno : integer) : longint;
var nextfat : integer;
    full_granules, last_sectors ,i,k : integer;
    size : longint;
    x : cocodir;
begin
  if (fileno >= 0) and (fileno <= actualcocodirs) then begin
     nextfat:= integer(a[fileno]^.first) and $00ff;
     size:=0;
     full_granules:=0;
     last_sectors:= 0;
     k:=0;
     (* gotoxy(1,20); *)
     (* clreol;writeln('Sizing file number ',fileno); *)
     (* clreol;putbyte(nextfat); writeln('H');   *)
     while ( (nextfat < 68) and ( k < 68) )  do begin
        k:=k+1;
        nextfat:=integer(cocofat[nextfat]) and $00ff;
        (* putbyte(nextfat);writeln('H') *);
     end;
     full_granules:= k -1 ;
     (* clreol;writeln('Full granules = ',k - 1);  *)
     last_sectors:=  nextfat and $0f;
     (* clreol;writeln('Sectors in partial granule = ',last_sectors);    *)
     (* clreol;writeln('Bytes in last sector = ',swap(a[fileno]^.lastbytes)); *)
     (* if last_sectors > 9 then writeln('Error in FAT table.'); *)
     (* so k is last partial block for file *)
     if nextfat = $ff then begin
       sizeit:= 100000;
       exit;
     end ; (* some stupid number *)
     size:= ( longint(full_granules) * longint(9)) * longint( 256);
     if (nextfat and $C0) = $c0 then begin
        if last_sectors > 0    then
            size:= size + (  longint(last_sectors -1 ) * longint(256) );
        if (last_sectors > 0)  then
            size:= size + longint( swap(a[fileno]^.lastbytes));
        sizeit:=size;
        (* clreol;putlong(size);writeln('H'); *)
     end
     else   sizeit:= 1111111
   end else sizeit:= 2222222;
end; (* sizeit *)

function readgranule(gran : integer) : integer;
var  trak,side,sect,buffercount,i : integer;
     ch : char;
begin
   if (gran <= 67)  then begin
       granule2trksec(gran,trak,side,sect);    (* get starting track/sector *)
       { read a granuleation block }
       for i:=0 to 8 do begin
          if readsec(trak,side,sect) then begin end
          else begin
              errmessage(1,'Bad Sector. Press <ESC> to abort.');
              ch:=readkey;
              if ch= #27 then begin readgranule:= -1; exit; end;
          end;
          buffercount:=buffercount+256;
          advance(trak,side,sect);  (* go to next sector in granule *)
       end;
       readgranule:= 1 ;
   end else readgranule:= -2;
end; (* read granule *)

function writegranule(gran : integer) : integer;
var  trak,side,sect,buffercount,i : integer;
     ch : char;
begin
buffercount:=0;
if (gran <= 67)  then begin
    granule2trksec(gran,trak,side,sect);    (* get starting track/sector *)
    { read a granuleation block }
    for i:=0 to 8 do begin
       if writesec(trak,side,sect) then begin end
       else begin
            errmessage(1,'Bad Sector. Press <ESC> to abort.');
            ch:=readkey;
            if ch= #27 then begin writegranule:=-1;exit; end;
       end;
       buffercount:=buffercount+256;
       advance(trak,side,sect);  (* go to next sector in granule *)
    end;
    writegranule:= 1;
end else writegranule:= -2;
end; (* read granule *)


(* following to put out a line of hex *)


procedure putout( x : char ; y : integer);
var z : byte;
 begin
   z:= ord(x);
   if (y and PRT) <> 0 then write(lst,x);
   if (y and SCR) <> 0 then write(x);
   if ((y and HEX) = HEX) then gethex16(z);
 end;

procedure viewblock(totalbytes, gran : integer ; prntmode  : byte);
{ expands tabs }
var i,j, tabcount : integer;
    ch : char;
    s : nstring;
    TEXTmode : boolean;
    HEXmode  : boolean;
(* sub procedure to handle output *)
(* use putout *)
begin
    HEXmode := ((HEX and prntmode) = HEX);
    TEXTmode:= not HEXmode;
    if panic <= 0 then exit;
    tabcount:=0;
 if readgranule(gran) >=0 then begin
      { list an granulation block output goes to console in hex or ascii }
       for i:=0 to ( totalbytes -1) do begin
         { check keyboard }
         if checkabort then begin
            panic:=-1;
            errmessage(2,'User abort.');
            delay(500);
            exit;
         end;
         if TEXTmode then begin
            ch:=  chr( buffer^[i] );
            if ch = #$ff then ch:=#$1a;
            ch:= chr( ord(ch) and $7f);
         end
         else 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 : begin (* end of line is just a $0d *)
                       tabcount:=0;
                       putout(ch,prntmode);
                 end;
         #$1A  : begin
                    if TEXTmode  then begin
                         panic:=0;
                         exit;
                      end else putout(ch,prntmode);
                   end;
         #$0d  : begin
                    tabcount:=0;
                    if TEXTmode then putout(#$0a,prntmode);
                    putout(ch,prntmode);
                  end;
          #$09  :begin
                   s:= copy('          ',1, 8 - (tabcount mod 8));
                   if TEXTmode then for j:=1 to length(s) do
                        putout(s[j],prntmode)
                    else putout(ch,prntmode);
                    tabcount:=0;
                  end;
          else begin
                  if TEXTmode then
                        tabcount:=(tabcount+1) mod 8;
                  putout(ch,prntmode);
               end;
           end; { case }
     end; { for }
 end;  { if  >= 0 }
end; {viewblock }


procedure view( fileno  : integer; prntmode : integer);
var i,j,k : integer;
    granule : granuletable;  { allow up to 68 granules per file }
    finish : tristate;
    totalbytes,last_full,last_sector,last_bytes : integer;
begin
     panic:=1; { ok so far }
     inithex; (* in case need hex output *)
     last_full:= -1;
     last_sector:=-1;
     last_bytes:=0;totalbytes:=0;
     k:=0;
     for i:=0 to 67 do granule[i]:=$FF; { initialize it }
     i:=fileno;
     traverse( fileno, granule, last_full, last_sector, last_bytes);
     (* fill array with granule numbers *)
     (* return number of full granules,
        number of full sectors, and number
        of bytes in last partial sector *)
     (* now do the full granules *)
     for k:=0 to (last_full -1)  do  begin
        totalbytes:= 9*256;
        viewblock(totalbytes,granule[k],prntmode);
        if  panic<=0  then begin
            if HEX and prntmode <> 0 then sendouthexline;
            delay(500);
            exit;
         end;  (* if *)
       end;    (* for *)
       (* now do the partial granule *)
      totalbytes:= (last_sector)*256 + last_bytes;
      viewblock(totalbytes,granule[last_full],prntmode);
      presscrlf;
end; { view }


var setASCII : boolean;
    myprivate : array[0..4607] of byte;
    (* worst cse of all CR's , so twice a granule *)

function  ASCIIblockwrite(var dosfile: file;
            totalbytes : integer ) : integer;
(* returns the number of records written *)
(* changes CR to CR/LF on the fly *)
var x,lfchar : byte;
      i: integer;
      result,count : integer;

begin
       count:=0;
       {$I-}
       lfchar:=10;
   for i:= 0 to min(2303,(totalbytes -1)) do begin
       x:= buffer^[i];
       myprivate[count]:=x;
       count:=count+1;
       if x = 13 then begin
           myprivate[count]:=lfchar;
           count:=count+1;
       end;
   end;
   {$I+}
        blockwrite(dosfile,myprivate[0],count,result);
   {$I-}
        asciiblockwrite:=result;
end; (* ascii *)


(* copy totalbytes from granule gran into dos file *)

function  copyblock( var dosfile : FILE;
                     gran: integer ; totalbytes : integer ) : integer ;
var i, count,myioresult : integer;
    ch : char;
begin
 if readgranule(gran) >= 0 then begin
      if not setASCII then begin
           {$I-}  (* now write it in one burst *)
           blockwrite(dosfile,buffer^[0], totalbytes );
           myioresult:=ioresult;
           copyblock:=myioresult;
           {$I+}
           clreol;
           (* writeln(' BLOCKWRITE  ',totalbytes:10,
                   '  bytes with error ',myioresult:10);    *)
       end else begin
            (* now write it in one burst *)
            (* but insert CR/LF for CR *)
            count:=ASCIIblockwrite(dosfile,totalbytes );
            myioresult:=ioresult;
            copyblock:=myioresult;
            clreol;
            (* writeln(' ASCIIBLOCKWRITE  from ',totalbytes:10,
                   '  to ',count:10,'  from bytes with error ',myioresult:10); *)
        end;
   end else copyblock := $7fff;
end; {copyblockbinary }
(* returns -2 for bad read, -1 for granule number, and ioresult otherwise *)



procedure copycoco(var dosfile : file ; fileno : integer);
(* copies file fileno to dosfile *)
label 2222, 2223;
var k : integer;
    granule : granuletable;  { allow up to 68 granules per file }
    totalbytes : integer;
    full_granules,full_sectors, left_over : integer;
begin
     { extract file blocks from directory }
clreol;
(* writeln('copying file number ',fileno); *)
clreol;
     if a[fileno]^.ascii = $ff then setASCII:=true
     else setASCII:=false;
     traverse( fileno, granule,full_granules, full_sectors,left_over );
     totalbytes:=  9*256 ;
     for k:= 0 to (full_granules -1) do  begin
       clreol;
       (* writeln('Copying granule ', k:4,'  ',
       granule[k] :4, '  ',totalbytes:4); *)
       if (copyblock(dosfile,granule[k],totalbytes)) <> 0 then goto 2223;
     end;
     totalbytes:= full_sectors*256 + left_over;
     clreol;
     (* writeln('Copying granule ', full_granules:4,'  ',
     granule[full_granules] :4,'  ',totalbytes); *)
     if copyblock(dosfile,granule[full_granules],totalbytes) <> 0 then begin goto 2223 end;
     goto 2222;
2223: errmessage(-1,'Error in copyblock.  ');
2222:
     close(dosfile);
end; { copycoco }

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,1); myio:=ioresult;
      {$I+}
     if myio <> 0 then begin
        gotoxy(1,messageline);
        clreol;
        write(#$07,'Invalid DOS file.');
        mkdosname:=false;
        delay(500);
        {$I-}
        close(dosfile);
        {$I+}
     end;
end; { mkdosname }


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


function mklast: integer; { make a list of last extents, with a tag }
var i,j : integer;
begin
   for i:=0 to 71 do begin
         thisdir[i].place:= i;
         thisdir[i].tag:=' ';
   end;
end; { mklast}

procedure dir2name( var dummy : nstring ; fileno : integer);
var j : integer;
    ch : char;
begin
   dummy:='';
   if fileno > actualcocodirs then dummy:='RANGE BAD';
   (* writeln('dir2name = ',i);  *)
   if a[fileno]^.key[0] = DeleteDir then begin
       dummy:= 'Deleted';
       exit;
   end;
   if a[fileno]^.key[0] = Unuseddir  then begin
       dummy:='Unused' ;
       exit;
   end;
   for j:=0 to 7 do begin
       ch:=chr(a[fileno]^.key[j] and $7f);
       if ch <> ' ' then dummy:=dummy+ch;
   end;
   dummy:=dummy+'.';
   for j:=8 to 10 do begin
       ch:=chr(a[fileno]^.key[j] and $7f);
       if ch <> ' ' then dummy:=dummy+ch;
    end; { for }
end; { dir2name }


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


procedure help76;
begin
  clrscr;
  writeln('        COCO File Transfer to MS-DOS ');
  writeln('    Copyright 1988 by Clarence Wilkerson');
  writeln;
  if ATflag then writeln(' Machine type is AT.') else
  writeln(' Machine type is XT.');
  if ATflag then writeln(' Drive 0 is ',drivetype[drive0]);
  if ATflag then writeln(' Drive 1 is ',drivetype[drive1]);
  if length(defaultstring) <> 0 then begin
       write(' COCO TRSDOS format is ');
       reverseCRT;
       write(defaultstring);
       normalCRT;
  end;
  gotoxy(1,11);
  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(' L - log new COCO disk     Z - or Q  back to DOS');
  writeln(' H - hex dump of file      ? - show this help screen');
  writeln(' S - traverse FAT ');
  writeln(' F - hex dump FAT table    D - hex dump directory.');
  writeln;
  writeln;
  if not havelogged then begin
       gotoxy(1,messageline);clreol;
       write(' No COCO disk logged yet.');
  end;
end; { help76 }

(* change disk76 type display to vfiler type *)
(* use first 18 lines, 4 files per line *)
(* use wordstar or keypad to change locations *)
(* at 4 files per line, have 8 + 3 + 1 + 3 = 16 /file + spaces *)


procedure position( m : integer);
(* goto  position m on screen  offset to start at row 4 col 3 *)
var x,y : integer;
begin
 m:= m mod MAXFILESperPAGE; (* size of file display is 4 columns by 18 rows *)
 x:= ((m mod NCOLS) * COLWIDTH) + 3;  (* columns *)
 y:= (m  div NCOLS)+ 5;          (* rows    *)
 gotoxy(x,y);
end; (* position *)

function coconame(m : integer) : nstring;
var i : integer;
    dummy : nstring;
begin
      if m > actualcocodirs then begin
          coconame:='BAD DIR';
          exit;
      end;
      if i <> -1 then begin
     (*  clreol;
         gotoxy(1,25);
      *)
      (* writeln('coconame dir2name m = ',m);
         readln;
      *)
         dir2name(dummy,m);
         dummy:=dummy + '                           ';
         dummy:=copy(dummy,1,20);
      end else dummy:='                    ';
        (*  writeln(dummy); *)
      coconame:=dummy;
end; (* coconame *)

procedure displayname(m : integer);
var i : integer;
    ch : char;
    s: nstring;
begin
 position(m);
 s:=coconame(m);
 for i:=1 to min( length(s),16)  do begin
    write(s[i]);end;
 for i:=COLWIDTH -1  downto (1+ min(length(s),16)) do write(' ');
 position(m);
end; (* displayname *)

procedure invertname(m : integer );
begin
 reverseCRT;
 displayname(m);
 normalCRT;
end; (* invert name *)

procedure update(k: integer);
{ display total of tagged files }
var m : integer;
    z : longint;
begin
  tagged:=0;
  if k > actualcocodirs then k:=actualcocodirs;
  for m:=0 to k do
     if  (thisdir[m].tag = 'T' )   then  begin
       z:= sizeit(m);
       tagged:=tagged+z;
     end;
     gotoxy(40,statusline);
     clreol;
     write('Tagged files = ',tagged:0,' bytes');
end; { update }

function closestscreen( k : integer) : integer;
var x : integer;
begin
    if k < 0 then k:=0;
    x:=  ( k div MAXFILESperPAGE ) * MAXFILESperPAGE ;
    if k > actualcocodirs then (* use best approx *) begin
          x:=((actualcocodirs+MAXFILESperPAGE-1) div MAXFILESperPAGE);
          x:=x * MAXFILESperPAGE;
    end;
    closestscreen:=x;
end; (* closestscreen *)

procedure fillscreen( k : integer);
var  dummy : nstring;
     i, m : integer;
{fill the screen below line 3 with directory entries }
begin
  if k > actualcocodirs then k:=actualcocodirs;
  if k < 0 then k:=0;
  m:=closestscreen(k);
if havelogged then begin
  clrscr;
  writeln('       COCO to MSDOS, copyright 1988 by Clarence Wilkerson');
  update(actualcocodirs);
  for i:=m to min( (m + MAXFILESperPAGE -1),actualcocodirs)  do begin
      if thisdir[i].tag='T' then invertname(i)
      else displayname(i);
  end; { m }
  end; { if have logged }
end; { fillscreen }

(* get first file on screen that contains file k *)


procedure configurmenu;
begin
end;

procedure dumphex(k : integer);
begin;
end;

procedure diskzap;
begin
end;


procedure tagdir;     (* main menu loop *)
var n,i,j,k,l,alldone : integer;
    ch : char;
    root,s : nstring;
    needsrefresh : boolean;
    junk,nnrows: integer;
    lastdir : integer;
begin
       help76;
       presscrlf;
       k:=0;
       tagged:=0;
       needsrefresh:=true;
    repeat  { until i> 71 }
        lastdir:=actualcocodirs;
        if havelogged then begin
           if needsrefresh then fillscreen(closestscreen(k));
           needsrefresh:=false;
           s:=coconame(k);
           gotoxy(3,statusline);
           reverseCRT;
           write(s);
           normalCRT;
           write('  ',sizeit(k) :6,' ',
               file_type[a[k]^.kind and $3],' ',
               ascii_flag[a[k]^.ascii and $1]);
           position(k);
        end; { if havelogged }
        { check for function keys, etc here }
        if not havelogged then begin
         repeat
          ch:=readkey;
          ch:=upcase(ch);
        until ch in ['L','X','Q',^Z,'Z'];
        end else begin
          ch:=readkey;ch:=upcase(ch);
        end;
          { LOCK OUT all options except L and exit
          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:= ^E;
                      #75  : { left arrow } ch:= ^S;
                      #77  : { right arrow} ch:= ^D;
                      #$50 : { down arrow}  ch:= ^X;
                      #$49 : { up page }    ch:= ^R;
                      #$51 : { down page}   ch:= ^C;
                      #71  : { home }       ch:= ^A;
                      #79  : { end }        ch:= ^F;
                   else ch:=' ';
               end; { case of special keys }
           end; { if special }
           case ch of
              #27 : begin
                       ch:=readkey;
                       { gobble next char also }
                    end;

               ^S,#8  : begin  (* go to left *)
                            if (k = closestscreen(k) ) then
                              k:= min(lastdir,k - 1 + MAXFILESperPAGE)
                            else k:=min(k-1,lastdir);
                            if k < 0 then k:= 0;
                            if k > lastdir then k:= lastdir;
                          end;

                ^D,' ',#09  : begin  (* go to right *)
                                  if (k < closestscreen(k+1)) then
                                          k:=closestscreen(k)
                                  else k:= min(k+1,lastdir);
                                  if k < 0 then k:=0;
                                  if k > lastdir then k:=lastdir;
                                end;
                 ^X,#$0d : begin    (* down one line *)
                           if havelogged then begin
                               if (k < closestscreen(k+NCOLS)) then
                                   k:= closestscreen(k)+( k mod NCOLS) +1
                               else k:=min(k+NCOLS,lastdir);
                           end;
                           if k > lastdir then k:=lastdir;
                           if k < 0 then k:=0;
                        end;
                 ^E   : begin  { backwards }
                       if havelogged then begin
                         junk:= lastdir - closestscreen(k) ;
                         if junk > MAXFILESperPAGE then nnrows:=NROWS-1
                         else nnrows:=junk div NCOLS;
                         if ( (k mod MAXFILESperPAGE) < NCOLS) then
                            (* sitting on top row, so jump to bottom of
                               previous column *)
                            k:= k-1 + NCOLS*(nnrows)
                         else   k:=k-NCOLS;
                         if k < 0 then k:=0;
                         if k > lastdir then k:=lastdir;
                       end; { if havelogged }
                         end;

                 'T'  :  begin            (* tag a file *)
                      if havelogged then begin
                           thisdir[k].tag:='T';
                           invertname(k);
                           if (k < closestscreen(k+1)) then
                              k:=closestscreen(k)
                           else k:= min(k+1,actualcocodirs);
                           update(lastdir);
                           end; { if havelogged }
                   end;

                 { put in other Disk76 commands }
                 'L' : begin
                          login;
                          if havelogged then begin (* help76; *)
                             lastdir:=actualcocodirs;
                             tagged:=0;
                             k:=0;
                             needsrefresh:=true;
                           end else
                           help76;
                           gotoxy(1,messageline+1);
                           clreol;
                           write('No COCO currently logged.');
                        end;
                 'U'   : begin  { untag }
                           if havelogged then begin
                             thisdir[k].tag:=' ';
                             displayname(k);
                             if (k < closestscreen(k+1)) then
                                k:=closestscreen(k)
                             else k:= min(k+1,lastdir);
                             update(lastdir);
                           end; { if havelogged }
                         end;

                 ^C   : begin  { down page }
                           if havelogged then begin
                              k:=closestscreen(k + MAXFILESperPAGE);
                              if k > lastdir then k:=0;
                              if k < 0 then k:=0;
                              needsrefresh:=true;
                           end; { if havelogged }
                     end;
                 ^R   : begin  { up page }
                           if havelogged then begin
                              k:=closestscreen(k-MAXFILESperPAGE);
                              if k > lastdir then k:=lastdir;
                              if k < 0 then k:=closestscreen(lastdir);
                              needsrefresh:=true;
                         end; { if havelogged }
                      end;

                 'V'   : begin  { view on console}
                           if havelogged then begin
                              dir2name(s,k);
                              clrscr;gotoxy(1,10);
                              view(k,SCR);
                              presscrlf;
                              needsrefresh:=true;
                           end; { if havelogged }
                         end;
                 'H'   : begin  { view HEX on console}
                           if havelogged then begin
                              dir2name(s,k);
                              clrscr;gotoxy(1,10);
                              view(k,HEX);
                              needsrefresh:=true;
                           end; { if havelogged }
                         end;

                  'D'   : begin  { directory HEX on console}
                           if havelogged then begin
                              clrscr;
                              dumpdir;
                              needsrefresh:=true;
                           end; { if havelogged }
                         end;

                  'F'   : begin  { FAT HEX on console}
                           if havelogged then begin
                              clrscr;
                              dumpfat;
                              needsrefresh:=true;
                           end; { if havelogged }
                         end;

                 'P'   : begin  { print to list device }
                         if havelogged then begin
                           dir2name(s,k);
                           gotoxy(1,messageline);
                           write('Printing file ');
                           reverseCRT;
                           write(s);
                           normalCRT;
                           view(k,PRT);
                           presscrlf;
                           needsrefresh:=true;
                         end; { if havelogged }
                         end;
                 'S'   : begin  { traverse FAT for this file }
                         if havelogged then begin
                           dir2name(s,k);
                           gotoxy(1,messageline);
                           print_traverse(k);
                         end; { if havelogged }
                         end;

                 'M'   : begin  { masscopy }
                         if havelogged then begin
                           masscopy(lastdir);
                         end; { if havelogged }
                         end;  { start copy now }
                 'F': begin
                             gotoxy(1,messageline);clreol;
                             write('Not implemented.');
                             pressCRLF;
                          end;

                'W'    : begin   { wildcard tag-untag }
                          if havelogged then begin
                            gotoxy(1,messageline);
                            clreol;
                            write('Tag or Untag <U,T>? ');
                            ch:=readkey;
                            write(ch);
                            ch:=upcase(ch);
                            if ch='T' then for l:=k to lastdir do
                               thisdir[l].tag:='T';
                            if ch='U' then for l:=k to lastdir do
                                thisdir[l].tag:=' ';
                            update(lastdir);
                            needsrefresh:=true;
                           end; { if havelogged }
                          end; { w }
                 '?'   : begin
                          help76;
                          pressCRLF;
                          needsrefresh:=true;
                        end;

                'C'        : begin
                                configurmenu;
                                needsrefresh:=true;
                             end;

                 'E'       : begin
                                diskzap;
                                needsrefresh:=true;
                             end;
                'Q',^Z,'Z','X' : begin   { abort }
                                gotoxy(1,messageline);clreol;
                                write('Return to DOS? ');
                                ch:=readkey;
                                write(ch);ch:=upcase(ch);
                                if ch='Y' then alldone:=$FF;
                               end;
                  else begin   (* arbitrary key stroke *)
                            if havelogged then begin
                                k:=k;
                            end;
                  end;{ if ch not T or CR, reshow entry }
              end; { case }
        until (alldone=$FF);
 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 disk 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;
end;   { allocbuffer }

{xx $I logo.inc}

procedure logo;
begin
     clrscr;
     gotoxy(1,statusline);
     writeln('Tandy RSDOS COCO FILE TRANSFER to MS-DOS FILES');
     writeln('Copyright, 3-31-87 by Clarence W. Wilkerson.');
     writeln('All rights reserved.');
     writeln;
     writeln('This  program transfers files from Tandy RSDOS   ');
     writeln('COCO disks to MS-DOS files. It requires the use of an');
     writeln('IBM-PC compatible computer, since disk access is done with');
     writeln('ROM BIOS calls.');
     writeln;
     writeln('In case of abnormal termination, reboot the system.');
     writeln;
     pressCRLF;
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 }




begin  { main }

    checkbreak:=false; { readkey returns #3 for ctl-break }
    MAXFILESperPAGE:=NCOLS*NROWS;
    isTHISat;
    is96tpi:=false;
    defaultstring:='TANDY SS DD, 18 512  per track, 35 tracks';
    getcmmnd(cmmdline);
    logo;
    if not allocbuffer then begin
       gotoxy(1,messageline);clreol;
       write(#$07);
       writeln('Can not allocate buffer space missing 64k boundary.');
       write('Aborting program.');
       delay(2000);
       halt;
    end;
    preserve; { save present disk environment }
    havelogged := false; { don't allow any operations until.. }
    log2phys:=2; { keep 128 bytes convention for simplicity }
    activefilename:='NoName.Yet';
    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.