home *** CD-ROM | disk | FTP | other *** search
/ Millennium Time Capsule / AC2000.BIN / disks / ac4_disk / hbasic / demos / diskcopy.bas < prev    next >
Encoding:
BASIC Source File  |  1987-09-15  |  2.7 KB  |  140 lines
  1. ' $option b
  2. ' this program uses the operating system libraries to copy a single
  3. ' sided disk from drive a: to drive B:
  4. ' the following three lines specify the libraries which are needed
  5. ' © HiSoft 1987
  6. '
  7. ' SCS
  8. '
  9.  
  10. library "BIOS","XBIOS"
  11.  
  12. defint a-z
  13.  
  14. cls
  15. locate 1,14
  16. print "Disk Copier ";chr$(189);" HiSoft 1987 - written in HiSoft BASIC";
  17. locate 3,19
  18. print "copies a single sided disk from A: to B:";
  19.  
  20. srcd=0                            'source drive number
  21. trgd=1                            'target drive number
  22.  
  23. gfm:
  24. locate 5,28
  25. print "format target (y/n): ";
  26. ans$=inkey$
  27. if ans$=="y" then
  28.     dim fmtbuf(4608)            'dimension the format buffer
  29.     print ans$;
  30.     fm=1
  31. elseif ans$=="n" then
  32.     print ans$;
  33.     fm=0
  34. else
  35.     goto gfm
  36. end if
  37.  
  38. wpr:
  39. frmem&=fre("")                    'figure out how many tracks can be buffered
  40. frmem&=frmem&-5120
  41. ttb&=frmem&\4608
  42. if ttb&>81 then ttb&=81
  43. ttbi&=(ttb&*2304)
  44.  
  45. dim trkbuf(ttbi&)                'this is the buffer
  46.  
  47. locate 10,21
  48. print "insert source in A: and target in B:";
  49.  
  50. ere1:
  51. locate 14,28
  52. print "hit any key to continue";
  53.  
  54. repeat getkey                    'use the BIOS to check if a key was pressed
  55.     if FNbconstat(2)=-1 then exit getkey
  56. end repeat getkey
  57.  
  58. nix&=FNbconin&(2)        'make sure no characters are buffered; call BIOS
  59.  
  60. locate 14,28
  61. print string$(23,32)
  62.  
  63. strk=0
  64. etrk=ttb&-2
  65.  
  66. do
  67.  
  68.     elf&=0                        'the current array element
  69.     for trk=strk to etrk        'the loop to read as much of the disk
  70.         rdtrk trk,elf&            'as memory allows
  71.         elf&=elf&+2308            'update element counter
  72.     next trk
  73.  
  74.     elf&=0
  75.     for trk=strk to etrk        'writes contents of buffer
  76.         if fm=1 then fmtrk trk    'format track if so desired
  77.         wrtrk trk,elf&
  78.         elf&=elf&+2308
  79.     next trk
  80.  
  81.     if etrk=79 then exit loop
  82.  
  83.     strk=etrk+1                    'next set of tracks
  84.     etrk=strk+ttb&-2
  85.     if etrk>79 then etrk=79
  86.  
  87. loop
  88.  
  89. locate 14,28
  90. print string$(23,32);
  91. locate 14,37
  92. nix=FNbconout(2,27)
  93. nix=FNbconout(2,"p"%)
  94. print "DONE!";
  95. nix=FNbconout(2,27)
  96. nix=FNbconout(2,"q"%)
  97. end
  98.  
  99. sub rdtrk(tct,el&)
  100. shared errno,srcd,trkbuf(1)
  101.  
  102.     locate 14,28
  103.     print "   reading track";tct;
  104.     errno=FNfloprd(varptr(trkbuf(el&)),srcd,1,tct,0,9)    'XBIOS floprd call
  105.     if errno<0 then call errorhndl
  106. end sub
  107.  
  108.  
  109. sub fmtrk(tct)
  110. shared errno,trgd,fmtbuf(1)
  111.  
  112.     locate 14,28
  113.     print "formatting track";tct;" ";
  114.     errno=FNflopfmt(varptr(fmtbuf(0)),0,trgd,9,tct,0,1)    'XBIOS flopfmt call
  115.     if errno<0 then call errorhndl
  116. end sub
  117.  
  118. sub wrtrk(tct,el&)
  119. shared errno,trgd,trkbuf(1)
  120.  
  121.     locate 14,28
  122.     print "   writing track";tct;" ";
  123.     errno=FNflopwr(varptr(trkbuf(el&)),trgd,1,tct,0,9)    'XBIOS flopwr call
  124.     if errno<0 then call errorhndl
  125. end sub
  126.  
  127. sub errorhndl
  128. shared errno
  129.  
  130.     locate 14,30
  131.     print string$(3,32);
  132.     nix=FNbconout(2,27)
  133.     nix=FNbconout(2,"p"%)
  134.     print "TOS error ";abs(errno);" ";
  135.     nix=FNbconout(2,27)
  136.     nix=FNbconout(2,"q"%)
  137.     stop
  138.  
  139. end sub
  140.