ATR Copy Center#

The ATR Copy Center is available as free software under the GPLv3 License

ATR image(info)

SPL source code:#

# ATR Copy Center
# 2008-2014 Carsten Strotmann
# 2014/03/15

const bl $20 ( blank )

const rd $40
const wr $80

const ddevic $300
const dunit  $301
const dcmnd  $302
const dstats $303
const dbuf   $304
const dtimlo $306
const dbyt   $308
const daux   $30A

const memtop $2E5 ( last free memory location )
const memlo  $2E7 ( first free memory location )
const appmhi $0E

var percom 12
var drvstat 17
var buf   $100
var dpath $100
var secbuf    2
var bufbase   2
var bufsize   2
var bufend    2
var secbuforg 2
var hsbase    2
var hss2u     2
var hsdrive   2
var siov      2
var siolen    2
var tracks    2
var secpertrack 2
var errorcode 1

var devid  1
var devnm  1
var bytsec 2
var sectors 2
var sector  2
var autoinc 1
var side   1
var i      2
var fcount 2
var cdigit 2
var sidetgl 2
var cnt    2
var debugflg 1

str stfilen "\FILE0000.ATR"
str sterror " Error"
str stwhile "while"
str streading "reading"
str stwriting "writing"
str stsector "Sector"
str stsize "size"
str stillegal "illegal"
str stcreating "creating"
str stmounting "mounting"
str stremoving "removing"
str statr "ATR"
str stsingle "single"
str stmedium "medium"
str stdouble "double"
str stauto "Auto"
str stincrement "increment"
str stpress "press"
str stkey "key"
str stdrive "Drive"
str ststatus "status"
str sttimeout "Timeout"
str stwd2793 "WD2798"
str stsrc "Src"
str stdest "(D3:) Dst"
str stdensity "Density"
str stdigit "Digit"
str ston "On "
str stoff "Off"
str stmake "make"
str stmount "mount"
str stcopy "Copy"
str stread "Read "
str stwrite "Write"
str stzeros0 "00000"
str stzeros1 "00000"
str stzeros2 "00000"
str stcompleted "completed"
str stsuccessfully "successfully"
str stunsuccessful "unsuccessfully"
str stcenter "Center"
str stdots "..."
str sttracks "Tracks"
str ststep "Step"
str strate "Rate"
str stsectrack "Sec/Track"
str stsides "Sides"
str stbytessec "Bytes/Sec"
str stencoding "Encoding"
str stside "Side"
str sthelpmsg "[H] for help"
str stnextcpy "[space] to start next copy"
str sthighspeed "high speed"
str stnormalspeed "normal speed"

: debug
  dup 20 20 at "debug:" disp dup .$ "  "  disp "  " disp . 
;

: debugk
  dup 20 20 at "debug:" disp dup .$ "  "  disp "  " disp . key drop
;

: dispspace
  disp space
;

: init ( -- )
  0 debugflg c!
  $44 devid c!
  1 devnm c!
  $80 bytsec !
  18 secpertrack
  720 sectors !
  1 autoinc c!
  0 side c!
  0 fcount !
  4 cdigit !
  end@ secbuf !
  $E459 hss2u !
  $E459 hsdrive ! 
  $E459 siov !
  end@ appmhi !
;

: lcls ( y -- )
  crsoff 0 at 156 emit ;

: insline ( y -- )
  0 at 157 emit ;

: clearline ( y -- )
  39 i ! {
     dup i at 31 emit
     i --
     i @ 0 = if break then
  } 
  drop
;

: rcls ( pos lines -- )
  i ! {
    dup lcls
    i -- 
    i @ 0 = if break then
  }
  drop
;
  
: line ( y -- )
  40 * $58 @ + 40 $52 fill ;

: colon ( -- )
  $3A emit ;

data bittable
     $01 $02 $04 $08
     $10 $20 $40 $80
end  

: bits ( n -- bm )
  bittable + c@ ;

code scopy
[    ldy #5 ]
[    jmp sc1 ]
end
code sc1 
[    lda stzeros1,y  ]
[    clc    ]
[    adc #1 ]
[    sta stzeros1,y ]
[    cmp #$3A ]
[    bne sc2  ]
[    lda #$30 ]
[    sta stzeros1,y ]
[    dey ]
[    bne sc1 ]
[    jmp sc2 ]
end
code sc2
[    rts     ]
end

: sio ( -- rc )
  siov @ call
  dstats c@
;

: secbuffetch ( -- ) 
  secbuf @ ;

: clearbuf
  buf $FF $FF fill
  0 buf c!
  0 buf $7F + c! 
;

: buf1 ( -- addr )
  buf 1+ ;

: preparesio
  $31 ddevic c!
  devnm c@ dunit c!
  7 dtimlo c!
  0 daux !
;

: writecmd
  wr dstats c!
  sio
;

: readcmd
  rd dstats c!
  sio
;

: getstatus ( -- rc )
  preparesio
  $53 dcmnd c!
  drvstat dbuf !
  4 dbyt !
  readcmd
;

: getsiolen ( n -- l )
  preparesio
  $68 dcmnd c!
  dunit c!
  secbuf @ dbuf !
  2 dbyt !
  readcmd drop
  secbuf @ @
  dup siolen !
;

: gethssio ( addr n -- )
  dup getsiolen dbyt !
  preparesio
  dunit c!
  $69 dcmnd c!
  dup dbuf ! daux !
  $40 dtimlo c!
  readcmd  
;

: gets2usio ( -- )
  appmhi @ 3 gethssio
  1 = if 
     appmhi @ hss2u ! 
     siolen @ appmhi +!
  then
;

: getdrvsio ( -- )
  hsbase @ appmhi !
  appmhi @ devnm @ gethssio
  1 = if 
     appmhi @ hsdrive ! 
     siolen @ appmhi +!
  then
  gets2usio
;

: cprint ( addr -- )
  c@ u. ;

: cprintplus ( addr n -- )
  + cprint ;

: printstatus
  stdrive disp
  ststatus disp colon drvstat cprint
  "    " disp stwd2793 disp colon drvstat 3 cprintplus cr
  sttimeout disp colon drvstat 2 cprintplus 
;

: mdquery ( tests for medium density )
  getstatus drop drvstat c@ $80 and 
  dup 0 > if
    1040 sectors !
    $80 bytsec !
    26 secpertrack !
  then ;

: clearpercom
  percom 12 0 fill ;

: getsectors ( -- sec )
  percom c@ percom 2 + @ >< * 
;

: getpercom ( -- rc )
  clearpercom  preparesio
  $4E dcmnd c!
  percom dbuf !
  12 dbyt !
  readcmd getsectors sectors ! 
;

: printpercom ( -- )
     sttracks disp colon                percom cprint
  cr ststep disp strate disp colon      percom 1 cprintplus
  cr stsectrack disp colon              percom 2+ @ >< u.
  cr stsides disp colon                 percom 4 cprintplus
  cr stencoding disp colon              percom 5 cprintplus
  cr stbytessec disp colon              percom 6 + @ >< u.
  cr stdrive disp ston disp colon       percom 8 cprintplus
  cr stsector disp colon                getsectors u.
;

# sio2usb code

: temp2dpath
  stfilen dpath strcpy 
;

: dpath2buf
  dpath buf strcpy
;

: s2ucmd
  $71 ddevic c! 0 dunit c! $80 dbyt !
;

: s2ucmdp
  ddevic c@ $71 = 
;

: gets2ustatus
  preparesio s2ucmd
  17 dbyt !
  drvstat dbuf !
  0 dcmnd c!  # get U status info
  readcmd
;

: makeatr
  clearbuf dpath2buf
  preparesio s2ucmd
  sectors @ dup >< daux !
  $FFFF = if 1 daux ! then
  bytsec @ $100 = if
    daux c@ $80 or daux c!
  else
    daux c@ $7F and daux c!
  then
  $07 dcmnd c! buf dbuf !
  $c8 dtimlo c! writecmd
;

: rmatr
  clearbuf dpath2buf
  preparesio s2ucmd
  $09 dcmnd c!
  $00 daux   !
  buf dbuf !
  $c8 dtimlo c! 
  writecmd
;

: mountatr
  clearbuf dpath2buf
  preparesio s2ucmd
  $BB daux c!
  $05 dcmnd c!
  buf dbuf !
  $c8 dtimlo c!
  writecmd 
;

: seccmd ( i cmd -- rc )
  preparesio dcmnd c!
  dup 4 < if $80 else bytsec @ then dbyt !
  daux ! secbuf @ dbuf !
;

: readsec ( i -- )
  $52 seccmd devnm @ dunit c! readcmd 
;

: writesec ( i -- )
  $50 seccmd 3 dunit c! writecmd
;

code fullquery ( checks if sector buffer is empty )
[    lda secbuf  ]
[    sta ta      ]
[    lda secbuf+1 ]
[    sta ta+1    ]
[    ldy #0      ]
[    tya         ]
end
code fq1
[    ora (ta),y	 ]
[    iny         ]
[    cpy bytsec  ]
[    bne fq1	 ]
[    jmp push0a  ]
end
  
# user interface code

: clearfcount
  0 fcount !
;

: toggleautoinc
  1 autoinc ctoggle
  clearfcount
;

: qclearfcount ( n -- )
  fcount @ swap > if clearfcount then
;

: printfile
    cdigit @ 1 = if 9     qclearfcount then 
    cdigit @ 2 = if 99    qclearfcount then 
    cdigit @ 3 = if 999   qclearfcount then 
    cdigit @ 4 = if 9999  qclearfcount then
    fcount @ >outbuf
    cdigit @ i ! {
        $30 ( ASCII 0 ) dpath dup c@ + 3 sidetgl @ + i @ + - c!
        i -- i @ 0 = if break then
    } 
    $A1  ( source = outbuf+1 )
    dpath dup c@ + $A0 c@ 3 sidetgl @ + + - ( dest )
    $A0 c@ cmove
;

: nextfile
  cdigit @ if
    fcount ++
    printfile
  then
;

: prevfile
  cdigit @ if
    fcount --
    fcount @ $FFFF = if 9999 fcount ! then
    printfile
  then
;

: nextside
  1 side ctoggle
  side @ if 65 else 66 then dpath dup c@ + 4 - c!
;

: toggleside
  1 sidetgl ctoggle
  sidetgl @ if nextside then
;

: printinfo
  $00 sectors !
  $80 bytsec !
  18 secpertrack !
  stdensity disp colon mdquery 0 > 
  if stmedium disp 
  else
    getpercom
    percom 2+ @ >< tracks ! 
    percom 6 + @ 1 = if
      stdouble disp $100 bytsec !
    else
      stsingle disp
    then
  then
  space stsector disp
  $73 emit colon
  sectors @ u. space space
;

: printsource
  5 2 at stsrc disp colon $44 emit 
  devnm c@ $30 + emit colon
  space printinfo
;

: printdestination
  crsoff 7 2 at stdest disp colon dpath disp " " disp
;

: printautoinc
  crsoff 9 2 at stauto disp stincrement disp colon
  autoinc @ if ston else stoff then disp
  9 20 at stdigit disp colon
  autoinc @ if cdigit @ else 0 then u.
  9 30 at stside disp colon
  sidetgl @ if ston else stoff then disp
;

: incdigit
  cdigit ++
  cdigit @ 5 = if
    0 autoinc c!
    0 cdigit !
  else
    1 autoinc c!
  then
;

: invertcursor ( i -- )
  dup dpath + c@ $80 xor
  swap dpath + c! printdestination 
;

: inccursor
  i @ dpath c@ < if i ++ then
;

: deccursor
  i @ 1        > if i -- then
;

: newname
  1 i ! 
  {
	i @ invertcursor
  	key 
 	i @ invertcursor  
        dup  47 = if drop 92 then     ( transpose / to \ )
  	dup $27 = if break then  ( ESC )   
  	dup $9B = if break then  ( RETURN )
  	dup  42 = if inccursor then  ( cursor right )
	dup  43 = if deccursor then  ( cursor left  )
        dup 157 = if dpath c@ 30 < if
                     i @ dpath + dup 1+ dpath c@ i @ - 1+ cmove>  ( INSERT )
                     bl i @ dpath + c!
                     dpath c@ 1+ dpath c! ( dpath c++ ) 
                  then then  
       ( dup $2F $59 within )
        dup $2C > if dup $5D < if dup dpath i @ + c! inccursor then then ( ALPHANUMERICAL ) 
        dup 126 = if dpath c@ i @ - 0 > if   ( DELETE )
                     i @ dpath + dup 1+ swap dpath c@ i @ - cmove
		     dpath c@ 1- dpath c!  ( dpath c-- )
                  then then
            125 = if 1 dpath c! 47 dpath 1+ c! then ( CLEAR )
  }
  drop
;

: beep 
  $FD emit
;

: clserr
  19 lcls 19 lcls 19 lcls 19 lcls
;

: errorwaitkey
  beep key drop clserr
;

: errorhead
   20 1 at sterror dispspace dstats c@ u. space
;

: prints2ustatus
  21 2 at gets2ustatus "Sio2USB:" disp drvstat 15 + c@  dup u. $2F emit $24 emit dup .$ space
  22 2 at 
     dup $2E = if "Illegal characters in filename" disp then
     dup $32 = if "USB device is not mounted" disp then
     dup $34 = if "ATR filename not allowed" disp then
     dup $35 = if "Directory not found" disp then
     dup $37 = if "Filename already exists, overwrite?" disp then
     dup $38 = if "Not enough free memory on storage" disp then
     dup $39 = if "No free root directory entry found" disp then
     drop 
;

: printerr 
  errorhead
  stwhile dispspace dispspace stsector dispspace
  s2ucmdp if
    prints2ustatus
  then key drop
;

: secerr
  errorhead 
  stillegal dispspace stsector dispspace stsize dispspace
  key drop 
;

: readerr
 streading printerr
;

: writeerr
 stwriting printerr
;

: makeerr
  errorhead
  stwhile dispspace stcreating dispspace statr dispspace
  prints2ustatus
  beep key clserr
;

: rmerr
  errorhead
  stwhile dispspace stremoving dispspace statr dispspace
  prints2ustatus
  beep key clserr
;

: mounterr
  errorhead
  stwhile dispspace stmounting dispspace statr dispspace
  prints2ustatus errorwaitkey
;

: resetcounter
  stzeros0 stzeros1 strcpy
;

: checkhighspeed ( addr -- )
  @ $E459 = 0if sthighspeed else stnormalspeed then disp  
;

: setsecbufbase
  appmhi @ $FF00 and $400 + bufbase !
  $7000 bufbase @ - bufsize !
  bufbase @ bufsize @ + bufend !
  $7000 appmhi !
  $7000 hsbase !
;

: readbuffer
  hsdrive @ siov !
  bufbase @ secbuf !
  stzeros1 stzeros2 strcpy
  sector @ i ! {
       i ++
       scopy 19 15 at stzeros1 disp debugflg @ if space secbuf @ .$ then # key drop
       i @ readsec errorcode c!
       bytsec @ secbuf +! 
       sectors @ i @ = if break then                   # last sector
       bufend @ secbuf @ = if break then               # buffer full?
       errorcode c@ $7F > if break then                # error during read?
  }
;

: writebuffer
  hss2u @ siov ! 
  bufbase @ secbuf !
  stzeros2 stzeros1 strcpy
  sector @ i ! {
       i ++
       scopy 
       fullquery 0 = 0if
         19 15 at stzeros1 disp debugflg @ if space secbuf @ .$ then  # key drop
         i @ writesec errorcode c!
       then
       bytsec @ secbuf +! 
       sectors @ i @ = if break then              # last sector
       bufend @ secbuf @ = if break then          # buffer full?
       errorcode c@ $7F > if break then           # error during write?
  }
  i @ sector !
;

: copy
  11 12 rcls
  printsource
  sectors @ not if 
    secerr exit
  then
  19 2 at stmake dispspace statr disp stdots disp
  makeatr 1 > if 
    makeerr $59 = 0if 
      exit 
    else 
      clserr 
      19 2 at "removing" dispspace statr disp stdots disp 
      rmatr 1 > if rmerr exit then  
      makeatr  1 > if makeerr exit then 
    then 
  then
  19 2 at stmount dispspace statr disp stdots disp
  mountatr 1 > if mounterr exit then
  19 8 at stsector dispspace stzeros1 disp
  15 2 at "Drive "   disp devnm c@ $30 + emit space  hsdrive checkhighspeed 
  debugflg @ if space hsdrive @ .$ then
  16 2 at "SIO2USB " disp hss2u checkhighspeed
  debugflg @ if space hss2u @ .$ then
  debugflg @ if
    12 2 at "Buffersize:" dispspace bufsize @ .$
    13 2 at "Bufend:" dispspace bufend @ .$
    14 2 at "APPMHI:" dispspace appmhi @ .$
  then
  bufbase @ secbuf !
  resetcounter 
  1 errorcode !
  0 sector !
  {
    19 2 at stread disp
    readbuffer errorcode c@ 1 > if readerr then
    errorcode c@ $80 < if
      19 2 at stwrite disp
      writebuffer errorcode c@ 1 > if writeerr then
    then
    sectors @ sector @ = if break then
    errorcode c@ $7F > if break then
  }
  $E459 siov ! ( reset to original SIOV )
  clserr stcopy dispspace 
  errorcode c@ $80 < if stsuccessfully else stunsuccessful then dispspace 
  stcompleted dispspace cr cr stnextcpy dispspace 
  autoinc @ if 
      sidetgl @ if 
         side @ if nextside else nextside nextfile then 
      else
         nextfile
      then
      printdestination
  then
;

: status
  11 12 rcls
  getstatus drop 11 2 at printstatus
  getpercom drop 14 2 at printpercom
;

: type ( caddr u -- )
  {
    swap dup c@ emit 1+ swap 1-
    dup 0 = if drop drop break then
  }
;

: printdirentry
  cnt @ 11 + 
  dup 20 > if 10 - 22 else 2 then at
  $10 * bufbase @ + 
  dup @ 0 = if drop exit then
  dup @ $80 and if drop exit then
  cnt ++
  dup @ $20 and if $2A emit else space then space
(  1+  dup @ .$ space ) ( Length )
(  2+  dup @ .$ space ) ( Start Sector )
  5 +  dup   8 type     ( Filename )
          $2e emit      ( . )
  8 +       3 type cr   ( Extender )
;

: showdirectory
  11 12 rcls
  0 cnt !
  bufbase @ secbuf !
  360 sector !
  {
    1 sector +! 
    sector @ readsec drop
    0 i !
    {
      cnt @ 22 = if 22 2 at " press key" disp key drop 0 cnt ! 11 12 rcls then
      i @ printdirentry
      i ++
      i @ $40 = if break then
    }
    sector @ 368 = if break then
  }
  22 2 at " press key" disp key drop
;

: ver 
  "1.2p2 SIO2USB" disp 
;

: banner
  cls
  $90 $2C6 c! crsoff
  statr disp stcopy disp stcenter disp 
  " (c) 2014 C. Strotmann" disp cr
  "Version " disp ver
  printsource         4 line
  printdestination    6 line
  printautoinc        8 line
                     10 line
  1 24 at sthelpmsg disp
;

: help
  11 12 rcls
  12 2 at "1-9  : select source and query disk" disp
  13 2 at " /   : edit ATR filename" disp
  14 2 at " A   : toggle autoincrement" disp
  15 2 at " +   : increment digits" disp
  16 2 at " B   : enable/disable diskside A/B" disp
  17 2 at " N/P : inc-/decrement number" disp
  18 2 at " X   : toggle diskside A/B" disp
  19 2 at " S   : print status" disp
  20 2 at " D   : print DOS 2.x directory" disp
  21 2 at " Q   : quit program" disp
  22 0 at " [SPACE] copy source disk to ATR" disp
;

: acc
  setsecbufbase
  1 devnm c! getdrvsio

  temp2dpath banner help
  {
     crsoff key crsoff
     dup $30 > if
         dup $3A < if
             dup $30 - devnm c! printsource getdrvsio
         then
     then
     dup $4E = if nextfile printdestination then
     dup $50 = if prevfile printdestination then
     dup $48 = if help then
     dup $20 = if copy then
     dup $3F = if help then
     dup $54 = if temp2dpath then
  (  dup $44 = if newpath 0 fcount ! 7 clearline printdestination then )
     dup $2F = if newname 0 fcount ! printdestination then
     dup $41 = if toggleautoinc printautoinc then
     dup $42 = if toggleside printautoinc printdestination then
     dup $2B = if incdigit  printautoinc then
     dup $53 = if status then
     dup $44 = if showdirectory help then
     dup $58 = if sidetgl @ if nextside  printdestination then then
     dup $51 = if exit then
     dup $7D ( CLEAR ) = if banner then
     dup $3F = if debugflg ctoggle 1 38 at debugflg @ if $44 else $20 then  emit then
     drop
   }
   cls crson
;
      
: main
  init
  acc
  bye
;