\ 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 modem.fth

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> abort" Xmodem already transferring"
	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
	if	fname modify fopen ?dup
		if fname xfname "copy (receive) exit then
	then	error-output ." Can't receive " fname ". restore-output ;

: send	\ name ( -- )
	1 xmodem-free? blword locals| fname |
	fname modify fopen ?dup
	if fname xfname "copy  (send) exit then
	error-output ." Can't send " fname ". restore-output ;
only forth also definitions
