\ 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
