home *** CD-ROM | disk | FTP | other *** search
/ Software 2000 / Software 2000 Volume 1 (Disc 1 of 2).iso / utilities / u155.dms / in.adf / PC / qldisk.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-01-20  |  23.8 KB  |  797 lines
  1. (*
  2.                     QLDISK V 3.1
  3.  
  4.    This program serves as Disk interface for the QL emulator on the Amiga 2000
  5.    with 8088 card. The Disk operations are performed via the dual ported
  6.    CGA RAM. The scratch area starts at segment $B800 and is defined as follows
  7.    :$0       Flag byte. =$AA => valid operation, =$55 => operation complete
  8.    :$1       Error return of last operation (QDOS standard)
  9.    :$2       Operation to be performed (=D0 on IO calls, D3 on Open calls)
  10.    :$3       ???
  11.    :$4       File number (0..15)
  12.    :$5       Strobe flag for file transfer
  13.    :$6-$BFFF Data to be transfered (Strings have one byte length at the start)
  14.  
  15. +2   THIS VERSION IS SPEEDED UP BY USE OF MS-DOS CALLS
  16. +3   The IO.FLINE bug is fixed
  17.      A backward path search is established
  18.      Access to MS-DOS files is provided by preceding the filename with @
  19.  
  20. *)
  21.  
  22. program QLDISK(INPUT,OUTPUT) ;
  23. {$U-} (* !!!!! disable BREAK !!!!! *)
  24. {$I-} (* disable any file errors *)
  25. const
  26.    TEMPDIR='C:TEMP$$.DIR' ;
  27.    ERRNC=255 ;  (* Not complete *)
  28.    ERRNF=249 ;  (* Not found *)
  29.    ERRNO=250 ;  (* Channel not found *)
  30.    ERREX=248 ;  (* allready exists *)
  31.    ERRIU=247 ;  (* In use *)
  32.    ERREF=246 ; (* End of file *)
  33.    ERRDF=245 ; (* Drive full *)
  34.    ERRFF=242 ; (* Format Failed *)
  35.    ERRBP=241 ; (* Bad parameter *)
  36.    ERRFE=240 ; (* Bad medium *)
  37.    ERRNI=237 ; (* Not implemented *)
  38.    ERRRO=236 ; (* Read only *)
  39.  
  40. type
  41.    REGISTER = RECORD
  42.               ax,bx,cx,dx,bp,si,di,ds,es,flags : INTEGER ;
  43.               END ;
  44.    BYTEARR  = ARRAY[0..4095] OF BYTE ;
  45.    STR80    = STRING[80] ;
  46.  
  47. var
  48.    es,bx               : INTEGER ;
  49.    error_code          : BYTE ;
  50.    search_string       : STR80 ;
  51.    cvterr              : ARRAY [0..255] OF BYTE ;
  52.    flag1,errflag,strb  : ^BYTE ;
  53.    fnum                : ^BYTE ;
  54.    op                  : ^BYTE ;
  55.    fname               : ^STR80 ;
  56.    fblock              : ^BYTEARR ;
  57.    FPTR                : ARRAY [0..255] OF INTEGER ;
  58.    FTYPE               : ARRAY [0..255] OF INTEGER ;
  59.    b                   : BYTE ;
  60.    n,m,i,dirflg        : INTEGER ;
  61.    x,y                 : REAL ;
  62.  
  63. (* ----------------------------------------------------------------------
  64.    Routines to read the Directory. They could be written in PASCAL using
  65.    the msdos() procedure, but I've taken them from the c't magazine.
  66.    The author prefered inline code, but if it is working, I'll take it.
  67.    ---------------------------------------------------------------------- *)
  68. procedure read_DTA ;
  69. (* DOS-CALL 02fh to read the DTA (ES:BX) *)
  70. BEGIN
  71.    inline
  72.    (  $b4/$2f/           (* mov ah,2f                       *)
  73.       $cd/$21/           (* int 21h                         *)
  74.       $89/$1e/bx/        (* mov (bx),bx        ; save bx    *)
  75.       $8c/$c3/           (* mov bx,es                       *)
  76.       $89/$1e/es)        (* mov (es),bx        ; save es    *)
  77. END ;
  78.  
  79. procedure find_first_entry(var search_string : STR80) ;
  80. (* DOS-CALL 04eh to find entry which is compatible with Search_string
  81.    Subsequent entries are found with DOS-CALL 04fh                    *)
  82. BEGIN
  83.    inline
  84.    (  $8b/$56/$04/       (* mov dx,[bp+04]     ; pointer to search_string *)
  85.       $81/$c2/$01/$00/   (* add dx,0001        ; skip length              *)
  86.       $b9/$10/$00/       (* mov cx,0010        ; find DIR entries too     *)
  87.       $b4/$4e/           (* mov ah,4e          ; find first file          *)
  88.       $cd/$21/           (* int 21h                                       *)
  89.       $a2/error_code);   (* mov (error_code),al                           *)
  90. END ;
  91.  
  92. procedure find_next_entry ;
  93. BEGIN
  94.    inline
  95.    (  $b4/$4f/           (* mov ah,4f          ; find next entry  *)
  96.       $cd/$21/           (* int 21h                               *)
  97.       $a2/error_code);   (* mov (error_code),al                   *)
  98. END ;
  99.  
  100. procedure decode_date(var year : INTEGER ; month,day,hour,min,sec : BYTE );
  101. BEGIN
  102.    year  := (mem[es:bx+25] shr 1) + 1980 ;
  103.    month := (mem[es:bx+25] and 1) * 8 +
  104.             (mem[es:bx+24] shr 5) ;
  105.    day   := (mem[es:bx+24] and 31) ;
  106.    hour  := (mem[es:bx+23] shr 3) ;
  107.    min   := (mem[es:bx+23] and 7) * 8 +
  108.             (mem[es:bx+22] shr 5) ;
  109.    sec   := (mem[es:bx+22] and 31) ;
  110. END ;
  111.  
  112. procedure decode_name(var fnam : STR80 ) ;
  113. var o : byte ;
  114. BEGIN
  115.    o:=30 ; fnam:='' ;
  116.    WHILE mem[es:bx+o]<>0 DO
  117.    BEGIN
  118.       fnam:=concat(fnam,chr(mem[es:bx+o])) ;
  119.       o:=o+1 ;
  120.    END ;
  121. END ;
  122. (* ----------------------------------------------------------------------- *)
  123.  
  124. procedure diskspace(var x,y : REAL) ;
  125. var
  126.    reg                 : REGISTER ;
  127.    lw                  : BYTE ;
  128. BEGIN
  129.    lw:=0 ;              (* operate on current drive *)
  130.    WITH reg DO BEGIN
  131.       ax:=$3600 ;       (* DOS-CALL free disk space *)
  132.       dx:=lw ;          (* Number of drive          *)
  133.       msdos(reg) ;
  134.       IF ax=$FFFF THEN BEGIN
  135.          x:=0 ;
  136.          y:=0 ;
  137.       END ELSE BEGIN
  138.          x:=1.0*ax*cx*dx ;
  139.          y:=1.0*ax*bx*cx ;
  140.       END ;
  141.    END ;
  142. END ;
  143. (* -------------------------------------------------------- *)
  144.  
  145. function curdisk : INTEGER ;
  146. var
  147.    reg                 : REGISTER ;
  148. BEGIN
  149.    WITH reg DO BEGIN
  150.       ax:=$1900 ;       (* DOS-CALL get current disk *)
  151.       msdos(reg) ;
  152.       curdisk:=lo(ax) ; (* drive number in al        *)
  153.    END ;
  154. END ;
  155. (* -------------------------------------------------------- *)
  156.  
  157. procedure Create_Handle ;
  158. var
  159.    reg                 : REGISTER ;
  160. BEGIN
  161.    fname^:=concat(fname^,CHR(0)) ;
  162.    WITH reg DO BEGIN
  163.       ds:=$B800 ; dx:=7 ; (* point to name *)
  164.       cx:=0 ;             (* no attribut   *)
  165.       ax:=$3C00 ;         (* ms-dos function number *)
  166.       msdos(reg) ;
  167.       errflag^:=0 ;
  168.       IF (flags and 1)<>0 THEN errflag^:=ERRNF ;
  169.       FPTR[fnum^]:=ax ;
  170.    END ;
  171.    FTYPE[fnum^]:=op^-128 ;
  172. END ;
  173. (* -------------------------------------------------------- *)
  174.  
  175. procedure Open_Handle ;
  176. var
  177.    reg                 : REGISTER ;
  178. BEGIN
  179.    fname^:=concat(fname^,CHR(0)) ;
  180.    WITH reg DO BEGIN
  181.       ds:=$B800 ; dx:=7 ;         (* point to name *)
  182.       ax:=0 ;                     (* assume open for read *)
  183.       IF (op^-128)=1 THEN ax:=2 ; (* read / write *)
  184.       ax:=ax+$3D00 ;              (* ms-dos function number *)
  185.       msdos(reg) ;
  186.       errflag^:=0 ;
  187.       IF (flags and 1)<>0 THEN errflag^:=ERRNF ;
  188.       FPTR[fnum^]:=ax ;
  189.    END ;
  190.    FTYPE[fnum^]:=op^-128 ;
  191. END ;
  192. (* -------------------------------------------------------- *)
  193.  
  194. procedure Close_Handle ;
  195. var
  196.    reg                 : REGISTER ;
  197. BEGIN
  198.    WITH reg DO BEGIN
  199.       bx:=FPTR[fnum^] ;
  200.       ax:=$3E00 ;             (* ms-dos function number *)
  201.       msdos(reg) ;
  202.       errflag^:=0 ;
  203.       IF (flags and 1)<>0 THEN errflag^:=ERRNF ;
  204.    END ;
  205. END ;
  206. (* -------------------------------------------------------- *)
  207.  
  208. procedure Read_Handle(start,n : INTEGER) ;
  209. var
  210.    reg                 : REGISTER ;
  211. BEGIN
  212.    WITH reg DO BEGIN
  213.       ds:=$B800 ; dx:=start ; (* point to buffer *)
  214.       bx:=FPTR[fnum^] ;       (* handle *)
  215.       cx:=n ;                 (* number of bytes *)
  216.       ax:=$3F00 ;             (* ms-dos function number *)
  217.       msdos(reg) ;
  218.       errflag^:=0 ;
  219.       IF ax<>n THEN errflag^:=ERREF ;
  220.       IF (flags and 1) <>0 THEN errflag^:=ERRNF ;
  221.    END ;
  222. END ;
  223. (* -------------------------------------------------------- *)
  224.  
  225. procedure Write_Handle(start,n : INTEGER) ;
  226. var
  227.    reg                 : REGISTER ;
  228. BEGIN
  229.    WITH reg DO BEGIN
  230.       ds:=$B800 ; dx:=start ; (* point to buffer *)
  231.       bx:=FPTR[fnum^] ;       (* handle *)
  232.       cx:=n ;                 (* number of bytes *)
  233.       ax:=$4000 ;             (* ms-dos function number *)
  234.       msdos(reg) ;
  235.       errflag^:=0 ;
  236.       IF (flags and 1) <>0 THEN errflag^:=ERRNF ;
  237.       IF ax<>n THEN errflag^:=ERRNF ;
  238.       IF ax=0 THEN errflag^:=ERRDF ;
  239.    END ;
  240. END ;
  241. (* -------------------------------------------------------- *)
  242. function XTRUNC(x : REAL) : INTEGER ;
  243. BEGIN
  244.    IF x<32768.0 THEN
  245.       XTRUNC:=TRUNC(x)
  246.    ELSE
  247.       XTRUNC:=TRUNC(x-65536.0) ;
  248. END ;
  249.  
  250. function DOSseek(p : REAL ; n : INTEGER) : REAL ;
  251. var
  252.    reg                 : REGISTER ;
  253. BEGIN
  254.    WITH reg DO BEGIN
  255.       cx:=TRUNC(p/65536.0) ;  (* split filepointer *)
  256.       dx:=XTRUNC(p-65536.0*cx) ;
  257.       bx:=FPTR[fnum^] ;       (* handle *)
  258.       ax:=n ;                 (* relative to: 0=begin,1=actual,2=end *)
  259.       ax:=ax+$4200 ;          (* ms-dos function number *)
  260.       msdos(reg) ;
  261.       errflag^:=0 ;
  262.       IF (flags and 1) <>0 THEN errflag^:=ERRNF ;
  263.       DOSseek:=dx*65536.0+hi(ax)*256.0+lo(ax) ;
  264.    END ;
  265. END ;
  266. (* -------------------------------------------------------- *)
  267.  
  268. function Fpos : REAL ;
  269. BEGIN
  270.    Fpos:=DOSseek(0.0,1) ;
  271. END ;
  272.  
  273. function Fsize : REAL ;
  274. var p : REAL ;
  275. BEGIN
  276.    p:=DOSseek(0.0,1) ;
  277.    Fsize:=DOSseek(0.0,2) ;
  278.    p:=DOSseek(p,0) ;
  279. END ;
  280.  
  281. (* -------------------------------------------------------- *)
  282. procedure BREAD(var b : BYTE ) ;
  283. BEGIN
  284.    Read_Handle($400,1) ;
  285.    b:=mem[$B800:$400] ;
  286. END ;
  287. procedure BWRITE(var b : BYTE ) ;
  288. BEGIN
  289.    mem[$B800:$400]:=b ;
  290.    Write_Handle($400,1) ;
  291. END ;
  292. (* -------------------------------------------------------- *)
  293.  
  294. procedure cvtfnam ;
  295. (* since QDOS uses the Underliner and MSDOS the Fullstop we have to convert
  296.    filenames from QDOS convention to MSDOS format.                          *)
  297. var
  298.    n,m,i,l             : INTEGER ;
  299. BEGIN
  300.    l:=length(fname^) ;
  301.    for i:=l-1 DOWNTO l-3 DO BEGIN
  302.       IF fname^[i]='_' THEN fname^[i]:='.' ;
  303.    END ;
  304. END ;
  305.  
  306. procedure litob(x : REAL ; var b1,b2,b3,b4 : BYTE) ;
  307. (* convert a long integer (I*4) into four bytes *)
  308. var
  309.    y,z                 : REAL ;
  310. BEGIN
  311.    y:=ABS(x) ;
  312.    z:=16777216.0 ; b4:=TRUNC(y/z) ; y:=y-b4*z ;
  313.    z:=65536.0    ; b3:=TRUNC(y/z) ; y:=y-b3*z ;
  314.    z:=256.0      ; b2:=TRUNC(y/z) ; y:=y-b2*z ;
  315.                    b1:=TRUNC(y) ;
  316. END ;
  317.  
  318. (* ------------------------------------------------------------
  319.               here we define the IO routines
  320.    ------------------------------------------------------------ *)
  321.  
  322. procedure OPENOLD ;
  323. var
  324.    n,ibm               : INTEGER ;
  325.    x                   : REAL ;
  326.    s,f                 : STR80 ;
  327. BEGIN
  328.    ibm:=0 ;                               (* assume QODS file *)
  329.    cvtfnam ;
  330.    n:=pos('@',fname^) ;
  331.    IF n>0 THEN BEGIN
  332.       ibm:=1 ;                             (* mark IBM file *)
  333.       fname^:=copy(fname^,1,n-1) + copy(fname^,n+1,length(fname^)) ;
  334.    END;
  335.    f:=fname^ ;
  336.    getdir(0,s) ; n:=length(s) ;
  337.    REPEAT
  338.      Open_Handle ;
  339.      WHILE (s[n]<>'\') AND (n>1) DO n:=n-1 ;
  340.      n:=n-1 ; s:=copy(s,1,n) ;
  341.      fname^:=s + '\' + f ;
  342.    UNTIL (errflag^=0) OR (n<2) ;
  343.    IF errflag^=0 THEN BEGIN
  344.       IF ibm=0 THEN x:=DOSseek(64.0,0) ;  (* skip file header *)
  345.       IF ibm=1 THEN FTYPE[fnum^]:=-1 ;    (* mark alien type  *)
  346.    END;
  347. END ;
  348.  
  349. (* ----------------------------------------------------------- *)
  350.  
  351. procedure OPENNEW ;
  352. var
  353.    b,b0                : BYTE ;
  354.    i,n,ibm             : INTEGER ;
  355. BEGIN
  356.    ibm:=0 ;
  357.    cvtfnam ;
  358.    n:=pos('@',fname^) ;
  359.    IF n>0 THEN BEGIN
  360.       ibm:=1 ;                             (* mark IBM file *)
  361.       WRITELN('ibm type file !') ;
  362.       fname^:=copy(fname^,1,n-1) + copy(fname^,n+1,length(fname^)) ;
  363.    END;
  364.    Create_Handle ;
  365.    IF (errflag^=0) AND (ibm=0) THEN BEGIN
  366.                                      (* skip first 14 bytes of file header *)
  367.       b0:=0 ;
  368.       FOR i:=1 TO 14 DO BWRITE(b0) ;
  369.       n:=length(fname^) ; b:=n ;
  370.       BWRITE(b0) ; BWRITE(b) ;       (* write length of name *)
  371.       FOR i:=1 TO n DO BEGIN
  372.          b:=ORD(fname^[i]) ;
  373.          BWRITE(b) ;                 (* write file name *)
  374.       END ;
  375.       b:=0 ;
  376.       FOR i:=n+1 TO 36 DO BWRITE(b) ;      (* skip excess bytes *)
  377.       FOR i:=1 TO 12 DO BWRITE(b) ;
  378.                        (* !!!!! Date stamp is not provided up to now !!!!! *)
  379.       dirflg:=0 ;      (* last directory is now invalid *)
  380.    END ;
  381.    IF ibm=1 THEN FTYPE[fnum^]:=-2 ;
  382. END ;
  383.  
  384. (* --------------------------------------------------------- *)
  385. procedure OPENDIR ;
  386. (* we do this by generating an artificial Directory in QDOS format as file
  387.    preferently in the RAM disk, and open this file for reading.           *)
  388. type
  389.    LINT    = ARRAY [0..3] OF BYTE ;
  390.    Filehdr = RECORD
  391.                    flen      : LINT ;
  392.                    access    : BYTE ;
  393.                    ftype     : BYTE ;
  394.                    info      : ARRAY [0..7] OF BYTE ;
  395.                    spare     : BYTE ;
  396.                    filnam    : STRING[36] ;
  397.                   date,d1,d2 : LINT ;
  398.              END ;
  399.    DIRECT  = FILE OF Filehdr ;
  400. var
  401.    month,day,hour      : BYTE ;
  402.    minute,second       : BYTE ;
  403.    b0,b1,b2,b3,b4      : BYTE ;
  404.    n,m,i,year          : INTEGER ;
  405.    fnam                : STR80 ;
  406.    td                  : DIRECT ;
  407.    Qdate,Flen          : REAL ;
  408.    Fhdr                : Filehdr ;
  409.  
  410. BEGIN
  411.   b0:=0 ;
  412.   IF dirflg=0 THEN BEGIN
  413.      assign(td,TEMPDIR) ;
  414.      close(td) ;
  415.      erase(td) ; i:=ioresult ;
  416.      assign(td,TEMPDIR) ;
  417.      rewrite(td) ;
  418.      read_DTA ;
  419.      search_string:='*.*'+chr(0) ; (* !!!! may be changed !!!! *)
  420.      find_first_entry(search_string) ;
  421.      WHILE error_code=0 DO BEGIN
  422.         decode_name(fnam) ;
  423.         IF mem[es:bx+21]=$10 THEN fnam:=concat(fnam,'--DIR--') ;
  424.         decode_date(year,month,day,hour,minute,second) ;
  425.         Flen:=mem[es:bx+26]+mem[es:bx+27]*256.0+mem[es:bx+28]*65536.0 ;
  426.         Flen:=Flen-64.0 ;            (* subtract bytes for fileheader *)
  427.         Qdate:=(year-1961)*31536000.0+month*2592000.0+day*86400.0+
  428.                hour*3600.0+minute*60.0+second ;
  429.         litob(Flen,b1,b2,b3,b4) ;
  430.         WITH fhdr DO BEGIN
  431.            flen[0]:=b4 ; flen[1]:=b3 ; flen[2]:=b2 ; flen[3]:=b1 ;
  432.            filnam:=fnam ;
  433.            access:=0 ;
  434.            ftype:=0 ;
  435.            spare:=0 ;
  436.            litob(Qdate,b1,b2,b3,b4) ;
  437.            date[0]:=b4 ; date[1]:=b3 ; date[2]:=b2 ; date[1]:=b1 ;
  438.            d1[0]:=b4 ; d1[1]:=b3 ; d1[2]:=b2 ; d1[1]:=b1 ;
  439.            d2[0]:=b4 ; d2[1]:=b3 ; d2[2]:=b2 ; d2[1]:=b1 ;
  440.         END ;
  441.         WRITE(td,fhdr) ;
  442.         find_next_entry ;
  443.      END ;
  444.      close(td) ;
  445.   END ;
  446.   dirflg:=1 ; (* make directory only if neccessary *)
  447.   fname^:=TEMPDIR ;
  448.   Open_Handle ;
  449. END ;
  450.  
  451. (* ----------------------------------------------------------- *)
  452.  
  453. procedure IOCLOSE ;
  454. var
  455.    t,b1,b2,b3,b4       : BYTE ;
  456.    flen,x              : REAL ;
  457. BEGIN
  458.    t:=FTYPE[fnum^] ;
  459.    CASE t OF
  460.       2,3: BEGIN              (* write filesize into file header *)
  461.               flen:=Fsize ;
  462.               litob(flen-64.0,b1,b2,b3,b4) ;
  463.               x:=DOSseek(0.0,0) ;
  464.               BWRITE(b4); BWRITE(b3); BWRITE(b2); BWRITE(b1) ;
  465.               x:=DOSseek(52.0,0) ;
  466.               b1:=fblock^[0] ; b2:=fblock^[1] ; (* get qdos date *)
  467.               b3:=fblock^[2] ; b4:=fblock^[3] ;
  468.               BWRITE(b1); BWRITE(b2); BWRITE(b3); BWRITE(b4) ; (* write date *)
  469.               x:=DOSseek(0.0,2) ;
  470.            END ;
  471.       END ;
  472.    Close_Handle ;
  473. END ;
  474. (* ---------------------------------------------------------------- *)
  475.  
  476. procedure IODELETE ;
  477. var
  478.    tp                  : FILE OF BYTE ;
  479. BEGIN
  480.    assign(tp,fname^) ;
  481.    close(tp) ;
  482.    erase(tp) ;
  483.    errflag^:=cvterr[ioresult] ;
  484.    dirflg:=0 ; (* last directory is now invalid *)
  485. END ;
  486. (* -------------------------------------------------------- *)
  487.  
  488. procedure IOPEND ;
  489. BEGIN
  490.    errflag^:=0 ;
  491.    IF Fpos=Fsize THEN errflag^:=ERREF ;
  492. END ;
  493. (* -------------------------------------------------------- *)
  494.  
  495. procedure IOFBYTE ;
  496. BEGIN
  497.    Read_Handle(6,1) ;
  498. END ;
  499. (* -------------------------------------------------------- *)
  500.  
  501. procedure IOFLINE ;
  502. var
  503.    b                   : BYTE ;
  504.    i,l,p               : INTEGER ;
  505. BEGIN
  506.    p:=2 ;
  507.    REPEAT
  508.       BREAD(b) ;
  509.       IF errflag^<>0 THEN b:=10 ;
  510.       fblock^[p]:=b ; p:=p+1 ;
  511.    UNTIL b=10 ;
  512.    l:=p-3 ; fblock^[0]:=hi(l) ; fblock^[1]:=lo(l) ;
  513. END ;
  514. (* -------------------------------------------------------- *)
  515.  
  516. procedure IOFSTRG ;
  517. var
  518.    b                   : BYTE ;
  519.    i,l,p               : INTEGER ;
  520.    fsmp                : REAL ;
  521. BEGIN
  522.    fsmp:=Fsize-Fpos ;
  523.    l:=256*fblock^[0]+fblock^[1] ;
  524.    IF fsmp<l THEN l:=TRUNC(fsmp) ;
  525.    Read_Handle(8,l) ;
  526.    fblock^[0]:=hi(l) ; fblock^[1]:=lo(l) ;
  527.    IF l=0 THEN errflag^:=ERREF ;
  528. END ;
  529. (* -------------------------------------------------------- *)
  530.  
  531. procedure IOSBYTE ;
  532. BEGIN
  533.    Write_Handle(6,1) ;
  534. END ;
  535. (* -------------------------------------------------------- *)
  536.  
  537. procedure IOSSTRG ;
  538. var
  539.    i,l                 : INTEGER ;
  540.    b                   : BYTE ;
  541. BEGIN
  542.    l:=256*fblock^[0]+fblock^[1] ;
  543.    Write_Handle(8,l) ;
  544. END ;
  545. (* -------------------------------------------------------- *)
  546.  
  547. procedure FSCHECK ; (* not really neccessary *)
  548. BEGIN
  549.    errflag^:=0 ;
  550. END ;
  551. (* -------------------------------------------------------- *)
  552.  
  553. procedure FSFLUSH ;
  554. BEGIN
  555.    errflag^:=0 ;
  556. END ;
  557. (* -------------------------------------------------------- *)
  558.  
  559. procedure FSPOSAB ;
  560. var
  561.    b1,b2,b3,b4         : BYTE ;
  562.    x,y                 : REAL ;
  563. BEGIN
  564.    x:=fblock^[1]*65536.0+fblock^[2]*256.0+fblock^[3] ;
  565.    x:=x+64.0 ;                           (* add 64 bytes of fileheader *)
  566.    x:=DOSseek(x,0) ;
  567.    IF errflag^<>0 THEN BEGIN
  568.       x:=DOSseek(0.0,2) ;
  569.       x:=x-64.0 ;                        (* take care about fileheader *)
  570.       litob(x,b1,b2,b3,b4) ;
  571.       fblock^[1]:=b3 ; fblock^[2]:=b2 ; fblock^[3]:=b1 ;
  572.    END ;
  573. END ;
  574. (* -------------------------------------------------------- *)
  575.  
  576. procedure FSPOSRE ;
  577. var
  578.    b1,b2,b3,b4         : BYTE ;
  579.    x,y                 : REAL ;
  580. BEGIN
  581.    y:=Fpos ;
  582.    x:=fblock^[1]*65536.0+fblock^[2]*256.0+fblock^[3] ;
  583.    IF x>8388607.0 THEN x:=x-16777216.0 ;
  584.    x:=x+y ;
  585.    x:=DOSseek(x,0) ;
  586.    IF errflag^<>0 THEN BEGIN
  587.       x:=DOSseek(0.0,2) ;
  588.    END ;
  589.    x:=x-64 ;                            (* take care about fileheader *)
  590.    litob(x,b1,b2,b3,b4) ;
  591.    fblock^[0]:=0 ; fblock^[1]:=b3 ; fblock^[2]:=b2 ; fblock^[3]:=b1 ;
  592. END ;
  593. (* ------------------------------------------------------ *)
  594.  
  595. procedure FSMDINF ;
  596. var
  597.    b1,b2,b3,b4         : BYTE ;
  598.    x,z                 : REAL ;
  599.    n,m,i               : INTEGER ;
  600.    s                   : STR80 ;
  601. BEGIN
  602.    diskspace(x,y) ; x:=x/512 ; y:=y/512 ; (* convert bytes to sectors *)
  603.    getdir(0,s) ;
  604.    litob(x,b1,b2,b3,b4) ;                   (* write good sectors *)
  605.    fblock^[2]:=b2 ; fblock^[3]:=b1 ;
  606.    litob(y,b1,b2,b3,b4) ;                   (* write free sectors *)
  607.    fblock^[0]:=b2 ; fblock^[1]:=b1 ;
  608.    FOR i:=4 TO 14 DO fblock^[i]:=32 ;       (* fill medium name with blanks *)
  609.    FOR i:=1 TO length(s) DO fblock^[i+3]:=ORD(s[i]) ;
  610.    errflag^:=0 ;
  611. END ;
  612. (* ------------------------------------------------------------- *)
  613.  
  614. procedure FSHEADS ;
  615. var
  616.    x,y                 : REAL ;
  617.    i                   : INTEGER ;
  618.    b                   : BYTE ;
  619. BEGIN
  620.    IF FTYPE[fnum^]>0 THEN BEGIN
  621.       x:=Fpos ;
  622.       y:=DOSseek(0.0,0) ;
  623.       Write_Handle(6,14) ;
  624.       y:=DOSseek(x,0) ;
  625.    END ;
  626. END ;
  627. (* -------------------------------------------------------------- *)
  628.  
  629. procedure FSHEADR ;
  630. var
  631.    x,y                 : REAL ;
  632.    i                   : INTEGER ;
  633.    b                   : BYTE ;
  634. BEGIN
  635.    IF FTYPE[fnum^]>0 THEN BEGIN
  636.       x:=Fpos ;
  637.       i:=0 ;
  638.       y:=DOSseek(0.0,0) ;
  639.       Read_Handle(6,64) ;
  640.       y:=DOSseek(x,0) ;
  641.    END ELSE BEGIN
  642.       FOR i:=6 TO 70 DO fblock^[i]:=0 ;
  643.    END ;
  644. END ;
  645. (* -------------------------------------------------------------- *)
  646.  
  647. procedure FSLOAD ;
  648. var
  649.    n,m,i               : INTEGER ;
  650.    b                   : BYTE ;
  651.    x                   : REAL ;
  652. BEGIN
  653.    x:=DOSseek(64.0,0) ;
  654.    IF errflag^=0 THEN BEGIN
  655.       WHILE errflag^=0 DO BEGIN
  656.          Read_Handle(6,512) ;
  657.          strb^:=$55  ;                 (* signal 'operation complete' *)
  658.          REPEAT
  659.             i:=strb^ ;
  660.          UNTIL i=$AA ;                 (* wait for 'ready'            *)
  661.       END ;
  662.       errflag^:=0 ;
  663.    END ;
  664. END ;
  665. (* ---------------------------------------------------------- *)
  666.  
  667. procedure FSSAVE ;
  668. var
  669.    n,m,i,j,k           : INTEGER ;
  670.    b                   : BYTE ;
  671. BEGIN
  672.    n:=(fblock^[1]*256+fblock^[2]) shr 1 ; (* get number of .5k blocks   *)
  673.    m:=(fblock^[2] and 1)*256+fblock^[3] ; (* get number of excess bytes *)
  674.    FOR k:=0 TO n DO BEGIN
  675.       strb^:=$55 ;                  (* signal 'ready to receive'   *)
  676.       REPEAT
  677.          i:=strb^ ;
  678.       UNTIL i=$AA ;                 (* wait for 'data ready'       *)
  679.       j:=512 ; IF k=n THEN j:=m ;
  680.       Write_Handle(6,j) ;
  681.    END ;
  682. END ;
  683. (* ---------------------------------------------------------- *)
  684.  
  685. procedure QCHDIR ;
  686. BEGIN
  687.    chdir(fname^) ; errflag^:=cvterr[ioresult] ;
  688.    dirflg:=0 ; (* last directory is now invalid *)
  689. END ;
  690.  
  691. procedure QDIR ;
  692. BEGIN
  693.    getdir(0,fname^) ; errflag^:=cvterr[ioresult] ;
  694. END ;
  695.  
  696. procedure MAKEDIR ;
  697. BEGIN
  698.    mkdir(fname^) ; errflag^:=cvterr[ioresult] ;
  699. END ;
  700.  
  701. procedure REMDIR ;
  702. BEGIN
  703.    rmdir(fname^) ; errflag^:=cvterr[ioresult] ;
  704. END ;
  705. (* ----------------------------------------------------------------- *)
  706.  
  707. procedure SERVE ;
  708. var
  709.    b                   : BYTE ;
  710.    n,m,i               : INTEGER ;
  711.    x,y                 : REAL ;
  712. BEGIN
  713.    WHILE flag1^<>255 DO BEGIN
  714.       REPEAT ; UNTIL flag1^=$AA ; { wait for anything to do }
  715.       i:=op^ ;
  716.       CASE i OF
  717.          $00: IOPEND ;
  718.          $01: IOFBYTE ;
  719.          $02: IOFLINE ;
  720.          $03: IOFSTRG ;
  721.          $04: errflag^:=ERRBP ; { Bad parameter error on IO.EDLIN }
  722.          $05: IOSBYTE ;
  723.          $06: errflag^:=ERRBP ;
  724.          $07: IOSSTRG ;
  725.          $08..$3F: errflag^:=ERRBP ;
  726.          $40: FSCHECK ;
  727.          $41: FSFLUSH ;
  728.          $42: FSPOSAB ;
  729.          $43: FSPOSRE ;
  730.          $45: FSMDINF ;
  731.          $46: FSHEADS ;
  732.          $47: FSHEADR ;
  733.          $48: FSLOAD ;
  734.          $49: FSSAVE ;
  735.          $4A..$7F: errflag^:=ERRBP ;
  736.      { Now follows the OPEN calls, which are identified by adding $80 }
  737.          $80: OPENOLD ;
  738.          $81: OPENOLD ;
  739.          $82: OPENNEW ;
  740.          $83: OPENNEW ;
  741.          $84: OPENDIR ;
  742.      { CLOSE calls are identified by $90 }
  743.          $90: IOCLOSE ;
  744.      { FORMAT calls are identified by $A0 }
  745.          $A0: errflag^:=ERRNI ; { Not implemented error on FORMAT }
  746.      { Special commands are given by adding $B0 }
  747.          $B0: QCHDIR ; { change directory }
  748.          $B1: QDIR ; { return actual directory }
  749.          $B2: MAKEDIR ; { make new directory }
  750.          $B3: REMDIR ; { remove directory }
  751.      { DELETE is performed with $FF }
  752.          $FF: IODELETE ;
  753.    (*    ELSE : errflag^:=ERRBP ; { Bad parameter error if not in list } *)
  754.       END ;
  755.       flag1^:=$55 ; { signal "operation complete" }
  756.    END ; { of loop }
  757. END ; { of procedure SERVE }
  758.  
  759.  
  760. (* ---------------------------------------------------------------- *)
  761.  
  762. BEGIN
  763.    flag1   := ptr($B800,$0) ;
  764.    errflag := ptr($B800,$1) ;
  765.    strb    := ptr($B800,$5) ;
  766.    fnum    := ptr($B800,$4) ;
  767.    op      := ptr($B800,$2) ;
  768.    fname   := ptr($B800,$6) ;
  769.    fblock  := ptr($B800,$6) ;
  770.  
  771.    FOR i:=0 TO 255 DO cvterr[i]:=i ;
  772.    cvterr[$01]:=ERRNF ;
  773.    cvterr[$02]:=ERREF ;
  774.    cvterr[$03]:=ERRRO ;
  775.    cvterr[$04]:=ERREF ;
  776.    cvterr[$20]:=ERRIU ;
  777.    cvterr[$22]:=ERRNF ;
  778.    cvterr[$91]:=ERREF ;
  779.    cvterr[$99]:=ERREF ;
  780.    cvterr[$F0]:=ERRDF ;
  781.    cvterr[$F0]:=ERRDF ;
  782.    cvterr[$F2]:=ERRDF ;
  783.    cvterr[$FF]:=ERRFE ;
  784.    dirflg:=0 ; (* no directory ,made up to now *)
  785.  
  786.    (* set the QDOS identifier for the driver program on the QL-side *)
  787.    flag1^:=$4A ; errflag^:=$FB ;
  788.    (* now wait for reply from QDOS or any keystroke *)
  789.    REPEAT
  790.       IF flag1^=$AA THEN BEGIN
  791.          WRITELN('switching to QDOS...') ;
  792.          flag1^:=$55 ; (* signal 'ready' to QDOS *)
  793.          SERVE ; (* now go to serve QDOS *)
  794.       END ;
  795.       delay(2) ;
  796.    UNTIL keypressed
  797. END.