home *** CD-ROM | disk | FTP | other *** search
- \ Silent version using multitasking
- \ Xmodem protocol file transfer.
- \ Commands:
- \ send filename \ Sends the file
- \ receive filename \ Receives the file
- \ The serial line parameters are established by "init-modem", which
- \ you may edit if you need to use different ones.
- \ The xmodem protocol requires 8 data bits, so changing that parameter
- \ won't work.
-
- \ ***** Interface to the serial line: *****
- \ init-modem --
- \ Establishes the desired baud rate and # of bits on the serial line
- \ m-key? -- flag
- \ Flag is true if a character is available on the serial line
- \ m-key -- char
- \ Gets a character from the serial line
- \ m-emit char --
- \ Puts the character out on the serial line.
-
- only forth also definitions
- \needs modem cr .( OS specific modem driver must be loaded first) abort
-
- only forth also modem also modem definitions
- decimal
-
- variable checksum
- variable #errors
- variable #naks
- variable expected-sector
- variable #control-z's
- variable sector#
- variable sector-ptr
- variable timer-init
- variable timer
- variable xmodem-fd xmodem-fd off
- variable xmodem-#error
- variable xread/write \ 0 receive -- 1 sending
-
- string-array xmodem-errors
- ( 0 ) ," receive, read sector"
- ( 1 ) ," sending, write sektor"
- ( 2 ) ," receive, header"
- ( 3 ) ," receive, block"
- ( 4 ) ," receive, checksum"
- ( 5 ) ," receive, canceled"
- ( 6 ) ," receive, timeout"
- ( 7 ) ," receive, bogus char"
- ( 8 ) ," sending, timeout"
- ( 9 ) ," sending, canceled"
- ( 10) ," sending, received bogus char"
- ( 11) ," receive, Xmodem started"
- ( 12) ," sending, Xmodem started"
- ( 13) ," Xmodem finished"
- end-string-array
-
- 2 constant xmodem#channel
- 4 constant max#errors
- 0 constant nul
- 1 constant soh
- 4 constant eot
- 6 constant ack
- 21 constant nak
- 24 constant can
- 128 buffer: sector-buf
- 128 buffer: xfname
-
- : timeout: \ name ( seconds -- )
- create , does> @ ( seconds ) ticks/second * timer-init ! ;
- 3 timeout: short-timeout
- 6 timeout: long-timeout
- 60 timeout: initial-timeout
-
- short-timeout
- : xerr ( #error -- )
- xmodem-#error ! ;
- : init-modem ( -- ) \ initialize modem line
- 8-bits 2-stop-bits no-parity 9600-baud rts/cts set-line ;
- : close-xfile ( -- )
- xmodem-fd @ fclose xmodem-fd off
- m-close ;
- : abort-end ( -- ) \ abort and clean up
- close-xfile -1 xmodem-fd ! stop ;
- : normal-end ( -- ) \ clean up
- ack m-emit close-xfile d# 13 xerr stop ;
- : ?interrupt ( -- ) \ aborts if user types control Z
- key? if key control Z = if abort-end then then ;
- : timed-in ( -- char | -1 ) \ get a character unless timeout
- get-ticks timer-init @ + timer !
- begin m-key? if m-key exit then
- timer @ reached?
- until -1 ;
- : gobble ( -- ) \ eat characters until they stop coming
- short-timeout
- begin timed-in -1 = until
- long-timeout ;
- : read-sector ( adr -- end-of-file? )
- dup 128 xmodem-fd @ fgets tuck + ( count end-adr )
- \ Pad with control Z's if necessary
- over 128 swap - control Z fill 0= ;
-
- : write-sector ( adr -- ) \ write out the sector
- \ Dump out any control Z's left over from last time
- #control-z's @ 0 ?do control Z xmodem-fd @ fputc loop
- \ Count the control z's at the end of the buffer
- #control-z's off dup dup 127 + ( addr addr end-address )
- do i c@ control Z <> ?leave
- 1 #control-z's +!
- -1 +loop ( addr )
- 128 #control-z's @ - xmodem-fd @ fputs ;
-
- : receive-error ( #error -- ) \ eat rest of packet and send a nak
- xerr gobble 1 #naks +! #naks @ max#errors >
- if can m-emit abort-end then
- nak m-emit ;
-
- : receive-header ( -- f ) \ true if header error
- timed-in dup -1 = ?exit
- dup sector# !
- timed-in dup -1 = ?exit
- 255 xor <> ;
- : receive-sector ( -- f ) \ true if runt sector
- 0 xerr
- 0 checksum ! false
- sector-buf 128 bounds
- do timed-in dup -1 =
- if ( false -1 ) nip leave then ( false char )
- dup i c! checksum +!
- loop ( runt-sector? ) ;
- : receive-checksum ( -- f ) \ true if checksum error
- timed-in dup -1 <> ( char true | -1 false )
- if checksum @ 255 and <> then ;
- : receive-packet ( -- f ) \ true if end of transfer
- false timed-in
- case soh of endof
- nul of 1- exit endof
- can of 5 xerr abort-end endof
- eot of 1- normal-end exit endof
- -1 of 6 receive-error exit endof
- 7 receive-error exit
- endcase
- receive-header if 2 receive-error exit then
- receive-sector if 3 receive-error exit then
- receive-checksum if 4 receive-error exit then
- sector-buf write-sector ack m-emit
- 1 expected-sector +! #naks off ;
-
- : wait-ack ( -- ) \ wait for ack or can
- 0 #errors !
- begin #errors @ max#errors > #naks @ max#errors > or
- if can m-emit abort-end then
- ?interrupt timed-in
- case
- -1 of 1 #errors +! 8 xerr endof
- can of 9 xerr abort-end endof
- ack of #naks off exit endof
- nak of 1 #naks +! exit endof
- d# 10 xerr
- endcase
- again ;
- : wait-nak ( -- ) \ wait for nak
- initial-timeout timed-in
- case
- -1 of 8 xerr abort-end endof
- can of 9 xerr abort-end endof
- nak of 1 #naks +! exit endof
- d# 10 xerr
- endcase long-timeout ;
- : send-header ( -- ) \ header is soh sector# sector#not
- soh m-emit sector# @ 255 and dup m-emit 255 xor m-emit ;
- : send-sector ( -- )
- 1 xerr 0 checksum !
- sector-buf 128 bounds
- do i c@ dup m-emit checksum +! loop ;
- : send-checksum ( -- ) checksum @ 255 and m-emit ;
-
- : end-send ( -- )
- close-xfile
- begin eot m-emit wait-ack #naks @ 0=
- until ;
- : (x-setup) ( -- )
- xmodem#channel m-open init-modem
- multi #naks off #control-z's off sector# off ;
- : receive-setup \ ( -- )
- (x-setup) 1 expected-sector ! ;
- : send-setup \ ( -- )
- (x-setup) 1 sector# ! ;
- : xmodem-free? ( r/w flag )
- xmodem-fd @ 0> if d# -278 throw then xread/write ! ;
-
- \ (receive) and (send) are words executed by the Xmodem-server
- \ the expect xmodem-fd to be set correct
- : (xreceive) \ ( -- )
- receive-setup d# 11 xerr
- gobble nak m-emit
- begin ?interrupt receive-packet
- until d# 13 xerr stop ;
- : (xsend) \ ( -- )
- send-setup d# 12 xerr
- gobble wait-nak #naks off
- begin ?interrupt
- #naks @ 0=
- if sector-buf read-sector
- if end-send d# 13 xerr stop then
- then
- send-header send-sector send-checksum wait-ack
- #naks @ 0= if 1 sector# +! then
- again ;
-
- task: Xmodem-server
- : (receive) \ ( id -- )
- xmodem-fd ! ['] (xreceive) Xmodem-server start ;
- : (send) \ ( id -- )
- xmodem-fd ! ['] (xsend) Xmodem-server start ;
-
- forth definitions
- : .xmodem-info ( -- )
- ??cr xmodem-fd @ 0 <= if ." No Xmodem transfer" exit then
- ." Xmodem " xread/write @ 0=
- if ." reading " xfname ".
- cr ." read " expected-sector @ .d ." sectors"
- else ." writing " xfname ". 3 spaces
- xmodem-fd @ fsize 127 + 128 / .d ." sectors"
- cr ." sent " sector# @ .d ." sectors"
- then ;
- : receive \ name ( -- )
- 0 xmodem-free? blword locals| fname |
- fname make 0= if d# -273 throw then
- fname modify fopen ?dup 0= if d# -276 throw then
- fname xfname "copy (receive) ;
- : send \ name ( -- )
- 1 xmodem-free? blword locals| fname |
- fname read fopen ?dup 0= if d# -275 throw then
- fname xfname "copy (send) ;
- only forth also definitions
-