(*
                    QLDISK V 3.1

   This program serves as Disk interface for the QL emulator on the Amiga 2000
   with 8088 card. The Disk operations are performed via the dual ported
   CGA RAM. The scratch area starts at segment $B800 and is defined as follows
   :$0       Flag byte. =$AA => valid operation, =$55 => operation complete
   :$1       Error return of last operation (QDOS standard)
   :$2       Operation to be performed (=D0 on IO calls, D3 on Open calls)
   :$3       ???
   :$4       File number (0..15)
   :$5       Strobe flag for file transfer
   :$6-$BFFF Data to be transfered (Strings have one byte length at the start)

+2   THIS VERSION IS SPEEDED UP BY USE OF MS-DOS CALLS
+3   The IO.FLINE bug is fixed
     A backward path search is established
     Access to MS-DOS files is provided by preceding the filename with @

*)

program QLDISK(INPUT,OUTPUT) ;
{$U-} (* !!!!! disable BREAK !!!!! *)
{$I-} (* disable any file errors *)
const
   TEMPDIR='C:TEMP$$.DIR' ;
   ERRNC=255 ;  (* Not complete *)
   ERRNF=249 ;  (* Not found *)
   ERRNO=250 ;  (* Channel not found *)
   ERREX=248 ;  (* allready exists *)
   ERRIU=247 ;  (* In use *)
   ERREF=246 ; (* End of file *)
   ERRDF=245 ; (* Drive full *)
   ERRFF=242 ; (* Format Failed *)
   ERRBP=241 ; (* Bad parameter *)
   ERRFE=240 ; (* Bad medium *)
   ERRNI=237 ; (* Not implemented *)
   ERRRO=236 ; (* Read only *)

type
   REGISTER = RECORD
              ax,bx,cx,dx,bp,si,di,ds,es,flags : INTEGER ;
              END ;
   BYTEARR  = ARRAY[0..4095] OF BYTE ;
   STR80    = STRING[80] ;

var
   es,bx               : INTEGER ;
   error_code          : BYTE ;
   search_string       : STR80 ;
   cvterr              : ARRAY [0..255] OF BYTE ;
   flag1,errflag,strb  : ^BYTE ;
   fnum                : ^BYTE ;
   op                  : ^BYTE ;
   fname               : ^STR80 ;
   fblock              : ^BYTEARR ;
   FPTR                : ARRAY [0..255] OF INTEGER ;
   FTYPE               : ARRAY [0..255] OF INTEGER ;
   b                   : BYTE ;
   n,m,i,dirflg        : INTEGER ;
   x,y                 : REAL ;

(* ----------------------------------------------------------------------
   Routines to read the Directory. They could be written in PASCAL using
   the msdos() procedure, but I've taken them from the c't magazine.
   The author prefered inline code, but if it is working, I'll take it.
   ---------------------------------------------------------------------- *)
procedure read_DTA ;
(* DOS-CALL 02fh to read the DTA (ES:BX) *)
BEGIN
   inline
   (  $b4/$2f/           (* mov ah,2f                       *)
      $cd/$21/           (* int 21h                         *)
      $89/$1e/bx/        (* mov (bx),bx        ; save bx    *)
      $8c/$c3/           (* mov bx,es                       *)
      $89/$1e/es)        (* mov (es),bx        ; save es    *)
END ;

procedure find_first_entry(var search_string : STR80) ;
(* DOS-CALL 04eh to find entry which is compatible with Search_string
   Subsequent entries are found with DOS-CALL 04fh                    *)
BEGIN
   inline
   (  $8b/$56/$04/       (* mov dx,[bp+04]     ; pointer to search_string *)
      $81/$c2/$01/$00/   (* add dx,0001        ; skip length              *)
      $b9/$10/$00/       (* mov cx,0010        ; find DIR entries too     *)
      $b4/$4e/           (* mov ah,4e          ; find first file          *)
      $cd/$21/           (* int 21h                                       *)
      $a2/error_code);   (* mov (error_code),al                           *)
END ;

procedure find_next_entry ;
BEGIN
   inline
   (  $b4/$4f/           (* mov ah,4f          ; find next entry  *)
      $cd/$21/           (* int 21h                               *)
      $a2/error_code);   (* mov (error_code),al                   *)
END ;

procedure decode_date(var year : INTEGER ; month,day,hour,min,sec : BYTE );
BEGIN
   year  := (mem[es:bx+25] shr 1) + 1980 ;
   month := (mem[es:bx+25] and 1) * 8 +
            (mem[es:bx+24] shr 5) ;
   day   := (mem[es:bx+24] and 31) ;
   hour  := (mem[es:bx+23] shr 3) ;
   min   := (mem[es:bx+23] and 7) * 8 +
            (mem[es:bx+22] shr 5) ;
   sec   := (mem[es:bx+22] and 31) ;
END ;

procedure decode_name(var fnam : STR80 ) ;
var o : byte ;
BEGIN
   o:=30 ; fnam:='' ;
   WHILE mem[es:bx+o]<>0 DO
   BEGIN
      fnam:=concat(fnam,chr(mem[es:bx+o])) ;
      o:=o+1 ;
   END ;
END ;
(* ----------------------------------------------------------------------- *)

procedure diskspace(var x,y : REAL) ;
var
   reg                 : REGISTER ;
   lw                  : BYTE ;
BEGIN
   lw:=0 ;              (* operate on current drive *)
   WITH reg DO BEGIN
      ax:=$3600 ;       (* DOS-CALL free disk space *)
      dx:=lw ;          (* Number of drive          *)
      msdos(reg) ;
      IF ax=$FFFF THEN BEGIN
         x:=0 ;
         y:=0 ;
      END ELSE BEGIN
         x:=1.0*ax*cx*dx ;
         y:=1.0*ax*bx*cx ;
      END ;
   END ;
END ;
(* -------------------------------------------------------- *)

function curdisk : INTEGER ;
var
   reg                 : REGISTER ;
BEGIN
   WITH reg DO BEGIN
      ax:=$1900 ;       (* DOS-CALL get current disk *)
      msdos(reg) ;
      curdisk:=lo(ax) ; (* drive number in al        *)
   END ;
END ;
(* -------------------------------------------------------- *)

procedure Create_Handle ;
var
   reg                 : REGISTER ;
BEGIN
   fname^:=concat(fname^,CHR(0)) ;
   WITH reg DO BEGIN
      ds:=$B800 ; dx:=7 ; (* point to name *)
      cx:=0 ;             (* no attribut   *)
      ax:=$3C00 ;         (* ms-dos function number *)
      msdos(reg) ;
      errflag^:=0 ;
      IF (flags and 1)<>0 THEN errflag^:=ERRNF ;
      FPTR[fnum^]:=ax ;
   END ;
   FTYPE[fnum^]:=op^-128 ;
END ;
(* -------------------------------------------------------- *)

procedure Open_Handle ;
var
   reg                 : REGISTER ;
BEGIN
   fname^:=concat(fname^,CHR(0)) ;
   WITH reg DO BEGIN
      ds:=$B800 ; dx:=7 ;         (* point to name *)
      ax:=0 ;                     (* assume open for read *)
      IF (op^-128)=1 THEN ax:=2 ; (* read / write *)
      ax:=ax+$3D00 ;              (* ms-dos function number *)
      msdos(reg) ;
      errflag^:=0 ;
      IF (flags and 1)<>0 THEN errflag^:=ERRNF ;
      FPTR[fnum^]:=ax ;
   END ;
   FTYPE[fnum^]:=op^-128 ;
END ;
(* -------------------------------------------------------- *)

procedure Close_Handle ;
var
   reg                 : REGISTER ;
BEGIN
   WITH reg DO BEGIN
      bx:=FPTR[fnum^] ;
      ax:=$3E00 ;             (* ms-dos function number *)
      msdos(reg) ;
      errflag^:=0 ;
      IF (flags and 1)<>0 THEN errflag^:=ERRNF ;
   END ;
END ;
(* -------------------------------------------------------- *)

procedure Read_Handle(start,n : INTEGER) ;
var
   reg                 : REGISTER ;
BEGIN
   WITH reg DO BEGIN
      ds:=$B800 ; dx:=start ; (* point to buffer *)
      bx:=FPTR[fnum^] ;       (* handle *)
      cx:=n ;                 (* number of bytes *)
      ax:=$3F00 ;             (* ms-dos function number *)
      msdos(reg) ;
      errflag^:=0 ;
      IF ax<>n THEN errflag^:=ERREF ;
      IF (flags and 1) <>0 THEN errflag^:=ERRNF ;
   END ;
END ;
(* -------------------------------------------------------- *)

procedure Write_Handle(start,n : INTEGER) ;
var
   reg                 : REGISTER ;
BEGIN
   WITH reg DO BEGIN
      ds:=$B800 ; dx:=start ; (* point to buffer *)
      bx:=FPTR[fnum^] ;       (* handle *)
      cx:=n ;                 (* number of bytes *)
      ax:=$4000 ;             (* ms-dos function number *)
      msdos(reg) ;
      errflag^:=0 ;
      IF (flags and 1) <>0 THEN errflag^:=ERRNF ;
      IF ax<>n THEN errflag^:=ERRNF ;
      IF ax=0 THEN errflag^:=ERRDF ;
   END ;
END ;
(* -------------------------------------------------------- *)
function XTRUNC(x : REAL) : INTEGER ;
BEGIN
   IF x<32768.0 THEN
      XTRUNC:=TRUNC(x)
   ELSE
      XTRUNC:=TRUNC(x-65536.0) ;
END ;

function DOSseek(p : REAL ; n : INTEGER) : REAL ;
var
   reg                 : REGISTER ;
BEGIN
   WITH reg DO BEGIN
      cx:=TRUNC(p/65536.0) ;  (* split filepointer *)
      dx:=XTRUNC(p-65536.0*cx) ;
      bx:=FPTR[fnum^] ;       (* handle *)
      ax:=n ;                 (* relative to: 0=begin,1=actual,2=end *)
      ax:=ax+$4200 ;          (* ms-dos function number *)
      msdos(reg) ;
      errflag^:=0 ;
      IF (flags and 1) <>0 THEN errflag^:=ERRNF ;
      DOSseek:=dx*65536.0+hi(ax)*256.0+lo(ax) ;
   END ;
END ;
(* -------------------------------------------------------- *)

function Fpos : REAL ;
BEGIN
   Fpos:=DOSseek(0.0,1) ;
END ;

function Fsize : REAL ;
var p : REAL ;
BEGIN
   p:=DOSseek(0.0,1) ;
   Fsize:=DOSseek(0.0,2) ;
   p:=DOSseek(p,0) ;
END ;

(* -------------------------------------------------------- *)
procedure BREAD(var b : BYTE ) ;
BEGIN
   Read_Handle($400,1) ;
   b:=mem[$B800:$400] ;
END ;
procedure BWRITE(var b : BYTE ) ;
BEGIN
   mem[$B800:$400]:=b ;
   Write_Handle($400,1) ;
END ;
(* -------------------------------------------------------- *)

procedure cvtfnam ;
(* since QDOS uses the Underliner and MSDOS the Fullstop we have to convert
   filenames from QDOS convention to MSDOS format.                          *)
var
   n,m,i,l             : INTEGER ;
BEGIN
   l:=length(fname^) ;
   for i:=l-1 DOWNTO l-3 DO BEGIN
      IF fname^[i]='_' THEN fname^[i]:='.' ;
   END ;
END ;

procedure litob(x : REAL ; var b1,b2,b3,b4 : BYTE) ;
(* convert a long integer (I*4) into four bytes *)
var
   y,z                 : REAL ;
BEGIN
   y:=ABS(x) ;
   z:=16777216.0 ; b4:=TRUNC(y/z) ; y:=y-b4*z ;
   z:=65536.0    ; b3:=TRUNC(y/z) ; y:=y-b3*z ;
   z:=256.0      ; b2:=TRUNC(y/z) ; y:=y-b2*z ;
                   b1:=TRUNC(y) ;
END ;

(* ------------------------------------------------------------
              here we define the IO routines
   ------------------------------------------------------------ *)

procedure OPENOLD ;
var
   n,ibm               : INTEGER ;
   x                   : REAL ;
   s,f                 : STR80 ;
BEGIN
   ibm:=0 ;                               (* assume QODS file *)
   cvtfnam ;
   n:=pos('@',fname^) ;
   IF n>0 THEN BEGIN
      ibm:=1 ;                             (* mark IBM file *)
      fname^:=copy(fname^,1,n-1) + copy(fname^,n+1,length(fname^)) ;
   END;
   f:=fname^ ;
   getdir(0,s) ; n:=length(s) ;
   REPEAT
     Open_Handle ;
     WHILE (s[n]<>'\') AND (n>1) DO n:=n-1 ;
     n:=n-1 ; s:=copy(s,1,n) ;
     fname^:=s + '\' + f ;
   UNTIL (errflag^=0) OR (n<2) ;
   IF errflag^=0 THEN BEGIN
      IF ibm=0 THEN x:=DOSseek(64.0,0) ;  (* skip file header *)
      IF ibm=1 THEN FTYPE[fnum^]:=-1 ;    (* mark alien type  *)
   END;
END ;

(* ----------------------------------------------------------- *)

procedure OPENNEW ;
var
   b,b0                : BYTE ;
   i,n,ibm             : INTEGER ;
BEGIN
   ibm:=0 ;
   cvtfnam ;
   n:=pos('@',fname^) ;
   IF n>0 THEN BEGIN
      ibm:=1 ;                             (* mark IBM file *)
      WRITELN('ibm type file !') ;
      fname^:=copy(fname^,1,n-1) + copy(fname^,n+1,length(fname^)) ;
   END;
   Create_Handle ;
   IF (errflag^=0) AND (ibm=0) THEN BEGIN
                                     (* skip first 14 bytes of file header *)
      b0:=0 ;
      FOR i:=1 TO 14 DO BWRITE(b0) ;
      n:=length(fname^) ; b:=n ;
      BWRITE(b0) ; BWRITE(b) ;       (* write length of name *)
      FOR i:=1 TO n DO BEGIN
         b:=ORD(fname^[i]) ;
         BWRITE(b) ;                 (* write file name *)
      END ;
      b:=0 ;
      FOR i:=n+1 TO 36 DO BWRITE(b) ;      (* skip excess bytes *)
      FOR i:=1 TO 12 DO BWRITE(b) ;
                       (* !!!!! Date stamp is not provided up to now !!!!! *)
      dirflg:=0 ;      (* last directory is now invalid *)
   END ;
   IF ibm=1 THEN FTYPE[fnum^]:=-2 ;
END ;

(* --------------------------------------------------------- *)
procedure OPENDIR ;
(* we do this by generating an artificial Directory in QDOS format as file
   preferently in the RAM disk, and open this file for reading.           *)
type
   LINT    = ARRAY [0..3] OF BYTE ;
   Filehdr = RECORD
                   flen      : LINT ;
                   access    : BYTE ;
                   ftype     : BYTE ;
                   info      : ARRAY [0..7] OF BYTE ;
                   spare     : BYTE ;
                   filnam    : STRING[36] ;
                  date,d1,d2 : LINT ;
             END ;
   DIRECT  = FILE OF Filehdr ;
var
   month,day,hour      : BYTE ;
   minute,second       : BYTE ;
   b0,b1,b2,b3,b4      : BYTE ;
   n,m,i,year          : INTEGER ;
   fnam                : STR80 ;
   td                  : DIRECT ;
   Qdate,Flen          : REAL ;
   Fhdr                : Filehdr ;

BEGIN
  b0:=0 ;
  IF dirflg=0 THEN BEGIN
     assign(td,TEMPDIR) ;
     close(td) ;
     erase(td) ; i:=ioresult ;
     assign(td,TEMPDIR) ;
     rewrite(td) ;
     read_DTA ;
     search_string:='*.*'+chr(0) ; (* !!!! may be changed !!!! *)
     find_first_entry(search_string) ;
     WHILE error_code=0 DO BEGIN
        decode_name(fnam) ;
        IF mem[es:bx+21]=$10 THEN fnam:=concat(fnam,'--DIR--') ;
        decode_date(year,month,day,hour,minute,second) ;
        Flen:=mem[es:bx+26]+mem[es:bx+27]*256.0+mem[es:bx+28]*65536.0 ;
        Flen:=Flen-64.0 ;            (* subtract bytes for fileheader *)
        Qdate:=(year-1961)*31536000.0+month*2592000.0+day*86400.0+
               hour*3600.0+minute*60.0+second ;
        litob(Flen,b1,b2,b3,b4) ;
        WITH fhdr DO BEGIN
           flen[0]:=b4 ; flen[1]:=b3 ; flen[2]:=b2 ; flen[3]:=b1 ;
           filnam:=fnam ;
           access:=0 ;
           ftype:=0 ;
           spare:=0 ;
           litob(Qdate,b1,b2,b3,b4) ;
           date[0]:=b4 ; date[1]:=b3 ; date[2]:=b2 ; date[1]:=b1 ;
           d1[0]:=b4 ; d1[1]:=b3 ; d1[2]:=b2 ; d1[1]:=b1 ;
           d2[0]:=b4 ; d2[1]:=b3 ; d2[2]:=b2 ; d2[1]:=b1 ;
        END ;
        WRITE(td,fhdr) ;
        find_next_entry ;
     END ;
     close(td) ;
  END ;
  dirflg:=1 ; (* make directory only if neccessary *)
  fname^:=TEMPDIR ;
  Open_Handle ;
END ;

(* ----------------------------------------------------------- *)

procedure IOCLOSE ;
var
   t,b1,b2,b3,b4       : BYTE ;
   flen,x              : REAL ;
BEGIN
   t:=FTYPE[fnum^] ;
   CASE t OF
      2,3: BEGIN              (* write filesize into file header *)
              flen:=Fsize ;
              litob(flen-64.0,b1,b2,b3,b4) ;
              x:=DOSseek(0.0,0) ;
              BWRITE(b4); BWRITE(b3); BWRITE(b2); BWRITE(b1) ;
              x:=DOSseek(52.0,0) ;
              b1:=fblock^[0] ; b2:=fblock^[1] ; (* get qdos date *)
              b3:=fblock^[2] ; b4:=fblock^[3] ;
              BWRITE(b1); BWRITE(b2); BWRITE(b3); BWRITE(b4) ; (* write date *)
              x:=DOSseek(0.0,2) ;
           END ;
      END ;
   Close_Handle ;
END ;
(* ---------------------------------------------------------------- *)

procedure IODELETE ;
var
   tp                  : FILE OF BYTE ;
BEGIN
   assign(tp,fname^) ;
   close(tp) ;
   erase(tp) ;
   errflag^:=cvterr[ioresult] ;
   dirflg:=0 ; (* last directory is now invalid *)
END ;
(* -------------------------------------------------------- *)

procedure IOPEND ;
BEGIN
   errflag^:=0 ;
   IF Fpos=Fsize THEN errflag^:=ERREF ;
END ;
(* -------------------------------------------------------- *)

procedure IOFBYTE ;
BEGIN
   Read_Handle(6,1) ;
END ;
(* -------------------------------------------------------- *)

procedure IOFLINE ;
var
   b                   : BYTE ;
   i,l,p               : INTEGER ;
BEGIN
   p:=2 ;
   REPEAT
      BREAD(b) ;
      IF errflag^<>0 THEN b:=10 ;
      fblock^[p]:=b ; p:=p+1 ;
   UNTIL b=10 ;
   l:=p-3 ; fblock^[0]:=hi(l) ; fblock^[1]:=lo(l) ;
END ;
(* -------------------------------------------------------- *)

procedure IOFSTRG ;
var
   b                   : BYTE ;
   i,l,p               : INTEGER ;
   fsmp                : REAL ;
BEGIN
   fsmp:=Fsize-Fpos ;
   l:=256*fblock^[0]+fblock^[1] ;
   IF fsmp<l THEN l:=TRUNC(fsmp) ;
   Read_Handle(8,l) ;
   fblock^[0]:=hi(l) ; fblock^[1]:=lo(l) ;
   IF l=0 THEN errflag^:=ERREF ;
END ;
(* -------------------------------------------------------- *)

procedure IOSBYTE ;
BEGIN
   Write_Handle(6,1) ;
END ;
(* -------------------------------------------------------- *)

procedure IOSSTRG ;
var
   i,l                 : INTEGER ;
   b                   : BYTE ;
BEGIN
   l:=256*fblock^[0]+fblock^[1] ;
   Write_Handle(8,l) ;
END ;
(* -------------------------------------------------------- *)

procedure FSCHECK ; (* not really neccessary *)
BEGIN
   errflag^:=0 ;
END ;
(* -------------------------------------------------------- *)

procedure FSFLUSH ;
BEGIN
   errflag^:=0 ;
END ;
(* -------------------------------------------------------- *)

procedure FSPOSAB ;
var
   b1,b2,b3,b4         : BYTE ;
   x,y                 : REAL ;
BEGIN
   x:=fblock^[1]*65536.0+fblock^[2]*256.0+fblock^[3] ;
   x:=x+64.0 ;                           (* add 64 bytes of fileheader *)
   x:=DOSseek(x,0) ;
   IF errflag^<>0 THEN BEGIN
      x:=DOSseek(0.0,2) ;
      x:=x-64.0 ;                        (* take care about fileheader *)
      litob(x,b1,b2,b3,b4) ;
      fblock^[1]:=b3 ; fblock^[2]:=b2 ; fblock^[3]:=b1 ;
   END ;
END ;
(* -------------------------------------------------------- *)

procedure FSPOSRE ;
var
   b1,b2,b3,b4         : BYTE ;
   x,y                 : REAL ;
BEGIN
   y:=Fpos ;
   x:=fblock^[1]*65536.0+fblock^[2]*256.0+fblock^[3] ;
   IF x>8388607.0 THEN x:=x-16777216.0 ;
   x:=x+y ;
   x:=DOSseek(x,0) ;
   IF errflag^<>0 THEN BEGIN
      x:=DOSseek(0.0,2) ;
   END ;
   x:=x-64 ;                            (* take care about fileheader *)
   litob(x,b1,b2,b3,b4) ;
   fblock^[0]:=0 ; fblock^[1]:=b3 ; fblock^[2]:=b2 ; fblock^[3]:=b1 ;
END ;
(* ------------------------------------------------------ *)

procedure FSMDINF ;
var
   b1,b2,b3,b4         : BYTE ;
   x,z                 : REAL ;
   n,m,i               : INTEGER ;
   s                   : STR80 ;
BEGIN
   diskspace(x,y) ; x:=x/512 ; y:=y/512 ; (* convert bytes to sectors *)
   getdir(0,s) ;
   litob(x,b1,b2,b3,b4) ;                   (* write good sectors *)
   fblock^[2]:=b2 ; fblock^[3]:=b1 ;
   litob(y,b1,b2,b3,b4) ;                   (* write free sectors *)
   fblock^[0]:=b2 ; fblock^[1]:=b1 ;
   FOR i:=4 TO 14 DO fblock^[i]:=32 ;       (* fill medium name with blanks *)
   FOR i:=1 TO length(s) DO fblock^[i+3]:=ORD(s[i]) ;
   errflag^:=0 ;
END ;
(* ------------------------------------------------------------- *)

procedure FSHEADS ;
var
   x,y                 : REAL ;
   i                   : INTEGER ;
   b                   : BYTE ;
BEGIN
   IF FTYPE[fnum^]>0 THEN BEGIN
      x:=Fpos ;
      y:=DOSseek(0.0,0) ;
      Write_Handle(6,14) ;
      y:=DOSseek(x,0) ;
   END ;
END ;
(* -------------------------------------------------------------- *)

procedure FSHEADR ;
var
   x,y                 : REAL ;
   i                   : INTEGER ;
   b                   : BYTE ;
BEGIN
   IF FTYPE[fnum^]>0 THEN BEGIN
      x:=Fpos ;
      i:=0 ;
      y:=DOSseek(0.0,0) ;
      Read_Handle(6,64) ;
      y:=DOSseek(x,0) ;
   END ELSE BEGIN
      FOR i:=6 TO 70 DO fblock^[i]:=0 ;
   END ;
END ;
(* -------------------------------------------------------------- *)

procedure FSLOAD ;
var
   n,m,i               : INTEGER ;
   b                   : BYTE ;
   x                   : REAL ;
BEGIN
   x:=DOSseek(64.0,0) ;
   IF errflag^=0 THEN BEGIN
      WHILE errflag^=0 DO BEGIN
         Read_Handle(6,512) ;
         strb^:=$55  ;                 (* signal 'operation complete' *)
         REPEAT
            i:=strb^ ;
         UNTIL i=$AA ;                 (* wait for 'ready'            *)
      END ;
      errflag^:=0 ;
   END ;
END ;
(* ---------------------------------------------------------- *)

procedure FSSAVE ;
var
   n,m,i,j,k           : INTEGER ;
   b                   : BYTE ;
BEGIN
   n:=(fblock^[1]*256+fblock^[2]) shr 1 ; (* get number of .5k blocks   *)
   m:=(fblock^[2] and 1)*256+fblock^[3] ; (* get number of excess bytes *)
   FOR k:=0 TO n DO BEGIN
      strb^:=$55 ;                  (* signal 'ready to receive'   *)
      REPEAT
         i:=strb^ ;
      UNTIL i=$AA ;                 (* wait for 'data ready'       *)
      j:=512 ; IF k=n THEN j:=m ;
      Write_Handle(6,j) ;
   END ;
END ;
(* ---------------------------------------------------------- *)

procedure QCHDIR ;
BEGIN
   chdir(fname^) ; errflag^:=cvterr[ioresult] ;
   dirflg:=0 ; (* last directory is now invalid *)
END ;

procedure QDIR ;
BEGIN
   getdir(0,fname^) ; errflag^:=cvterr[ioresult] ;
END ;

procedure MAKEDIR ;
BEGIN
   mkdir(fname^) ; errflag^:=cvterr[ioresult] ;
END ;

procedure REMDIR ;
BEGIN
   rmdir(fname^) ; errflag^:=cvterr[ioresult] ;
END ;
(* ----------------------------------------------------------------- *)

procedure SERVE ;
var
   b                   : BYTE ;
   n,m,i               : INTEGER ;
   x,y                 : REAL ;
BEGIN
   WHILE flag1^<>255 DO BEGIN
      REPEAT ; UNTIL flag1^=$AA ; { wait for anything to do }
      i:=op^ ;
      CASE i OF
         $00: IOPEND ;
         $01: IOFBYTE ;
         $02: IOFLINE ;
         $03: IOFSTRG ;
         $04: errflag^:=ERRBP ; { Bad parameter error on IO.EDLIN }
         $05: IOSBYTE ;
         $06: errflag^:=ERRBP ;
         $07: IOSSTRG ;
         $08..$3F: errflag^:=ERRBP ;
         $40: FSCHECK ;
         $41: FSFLUSH ;
         $42: FSPOSAB ;
         $43: FSPOSRE ;
         $45: FSMDINF ;
         $46: FSHEADS ;
         $47: FSHEADR ;
         $48: FSLOAD ;
         $49: FSSAVE ;
         $4A..$7F: errflag^:=ERRBP ;
     { Now follows the OPEN calls, which are identified by adding $80 }
         $80: OPENOLD ;
         $81: OPENOLD ;
         $82: OPENNEW ;
         $83: OPENNEW ;
         $84: OPENDIR ;
     { CLOSE calls are identified by $90 }
         $90: IOCLOSE ;
     { FORMAT calls are identified by $A0 }
         $A0: errflag^:=ERRNI ; { Not implemented error on FORMAT }
     { Special commands are given by adding $B0 }
         $B0: QCHDIR ; { change directory }
         $B1: QDIR ; { return actual directory }
         $B2: MAKEDIR ; { make new directory }
         $B3: REMDIR ; { remove directory }
     { DELETE is performed with $FF }
         $FF: IODELETE ;
   (*    ELSE : errflag^:=ERRBP ; { Bad parameter error if not in list } *)
      END ;
      flag1^:=$55 ; { signal "operation complete" }
   END ; { of loop }
END ; { of procedure SERVE }


(* ---------------------------------------------------------------- *)

BEGIN
   flag1   := ptr($B800,$0) ;
   errflag := ptr($B800,$1) ;
   strb    := ptr($B800,$5) ;
   fnum    := ptr($B800,$4) ;
   op      := ptr($B800,$2) ;
   fname   := ptr($B800,$6) ;
   fblock  := ptr($B800,$6) ;

   FOR i:=0 TO 255 DO cvterr[i]:=i ;
   cvterr[$01]:=ERRNF ;
   cvterr[$02]:=ERREF ;
   cvterr[$03]:=ERRRO ;
   cvterr[$04]:=ERREF ;
   cvterr[$20]:=ERRIU ;
   cvterr[$22]:=ERRNF ;
   cvterr[$91]:=ERREF ;
   cvterr[$99]:=ERREF ;
   cvterr[$F0]:=ERRDF ;
   cvterr[$F0]:=ERRDF ;
   cvterr[$F2]:=ERRDF ;
   cvterr[$FF]:=ERRFE ;
   dirflg:=0 ; (* no directory ,made up to now *)

   (* set the QDOS identifier for the driver program on the QL-side *)
   flag1^:=$4A ; errflag^:=$FB ;
   (* now wait for reply from QDOS or any keystroke *)
   REPEAT
      IF flag1^=$AA THEN BEGIN
         WRITELN('switching to QDOS...') ;
         flag1^:=$55 ; (* signal 'ready' to QDOS *)
         SERVE ; (* now go to serve QDOS *)
      END ;
      delay(2) ;
   UNTIL keypressed
END.