\ Serial communications
\ RISC OS Forthmacs support for SerialDev by Hugo Fiennes
\ V 2.2 04.06.96
\ SerialDev driver found in risc_os.serialdev.????.driver
 
vocabulary modem  only forth also system also modem also definitions  decimal

200 constant rs-delay	\ used by many applications using #m-key
  5 constant #drivers	\ number of serial drivers used, each may have two ports
			\ driver0 is a fake
variable next-driver
nuser channel#		\ used serial channel by this job

create drivers		#drivers cells allot
create driver-names	#drivers d# 32 * allot
create channels		#drivers 2* cells allot

: >driver		( i -- addr )	cells drivers + ;
: >drivername		( i -- addr )	d# 32 *  driver-names + ;
: >channel		( i -- addr )	cells channels + ;
: last-channel		( -- n )	next-driver 1- 2* ;
: init-drivers	( -- )
	channel# off
	1 next-driver !
	drivers #drivers cells erase
        driver-names #drivers d# 32 * erase
        channels #drivers 2* cells erase ;  init-drivers
: load-driver	( name -- )
	astring "move dup count lower
	next-driver @ #drivers > if d# -630 throw then
	h# 2000 allocate if drop false exit then
	astring astring locals| loadaddress cli-string driver-id |
	push-hex driver-id (u.) loadaddress pack drop pop-base
	next-driver @ >drivername "move
	p" LOAD Forthmacs:devices.SerialDev." cli-string "copy
	cli-string "cat p" .driver " cli-string "cat  loadaddress cli-string "cat
	cli-string "cli
	if false else driver-id then
	?dup 0= if d# -631 throw then 
	next-driver @ >driver !
	1 next-driver +! ;
: use-channel	( n -- )
	dup 2 next-driver @ 2* within 0= if d# -632 throw then
	channel# ! ;

\ SerialDev driver function call interface using driver-id
: serial-error	d# -633 throw ;
code serial_function	\ ( r2 function-code -- result )
	r0	top		mov	\ set fuction-code
	r4	'user channel#	ldr
	r1	r4	1 #	and	\ set port#
	r2	sp		pop	\ get r2-data
	top	'body channels	adr
	top	top   r4 2 #asl	add
	top	top )		ldr
	top	0 #		cmp
	top	' serial-error	eq adr 
	lk	pc h# fc000003 # bic
	pc	top		mov
	top	r0		mov c;

\ All driver-functions use driver-id
: (m-emit)	( char -- err?)	0 serial_function ;
: (m-key)	( -- key/-1 )	0  1 serial_function ;
: (m-emit?)	( -- freeintx)	0  4 serial_function ;
: (m-key?)	( -- received#)	0  5 serial_function ;
: flush-tx	( -- )		0  6 serial_function drop ;
: flush-rx	( -- )		0  7 serial_function drop ;
: get-c-lines	( -- n )	-1 8 serial_function ;
: set-c-lines	( n -- )	8 serial_function drop ;
: get-m-lines	( -- n )	0  9 serial_function ;
: rx-errors	( -- err-mask)	0 10 serial_function ;
: break		( -- )		50 11 serial_function drop ;
: get-baud	( -- n )	-1 13 serial_function ;
: set-baud	( n -- )	dup 13 serial_function drop
				14 serial_function drop ;
: get-format	( -- n )	-1 15 serial_function ;
: set-format	( n -- )	15 serial_function drop ;
: get-control	( -- n )	-1 16 serial_function ;
: set-control	( n -- )	16 serial_function drop ;
: init-driver	( -- flag )	0 17 serial_function ;
: close-driver	( -- )		0 18 serial_function drop ;
: poll-driver	( -- )		0 19 serial_function drop ;

: 57600-baud	( -- )		57600 set-baud ;
: 38400-baud	( -- )		38400 set-baud ;
: 19200-baud	( -- )		19200 set-baud ;
: 9600-baud	( -- )		9600  set-baud ;
: 4800-baud	( -- )		4800  set-baud ;
: 2400-baud	( -- )		2400  set-baud ;
: 1200-baud	( -- )		1200  set-baud ;

: 1-stop-bit	( -- )		get-format b# 111011 and  set-format ;
: 2-stop-bits	( -- )		get-format b# 111011 and  b# 000100 or  set-format ;
: 8-bits	( -- )		get-format b# 111100 and  set-format ;
: 7-bits	( -- )		get-format b# 111100 and  b# 000001 or  set-format ;
: no-parity	( -- )		get-format b# 110111 and  set-format ;
: odd-parity	( -- )		get-format b# 000111 and  b# 001000 or  set-format ;
: even-parity	( -- )		get-format b# 000111 and  b# 011000 or  set-format ;

: no-flow-control		0 set-control ;
: rts/cts	( -- )		1 set-control ;
: xon/xoff	( -- )		2 set-control ;

: rts-on	( -- )		get-c-lines 2 or  set-c-lines ;
: dtr-on	( -- )          get-c-lines 1 or  set-c-lines ;
: rts-off	( -- )		get-c-lines [ 2 -1 xor ] literal and  set-c-lines ;
: dtr-off	( -- )		get-c-lines [ 1 -1 xor ] literal and  set-c-lines ;
: ring?		( -- f )	get-m-lines 4 and 0<> ;
: dsr?		( -- f )	get-m-lines 2 and 0<> ;
: cts?		( -- f )	get-m-lines 1 and 0<> ;
: set-line	( n -- )	; immediate

: m-emit	( char -- )	begin (m-emit?) 0= while 10 ms repeat (m-emit) drop ;
: m-key?	( -- flag )	(m-key?) 0<> ;
: m-key		( -- char )	begin m-key? 0= while 10 ms repeat (m-key) ;
: #m-key	( ms -- c/-1 )	-1 swap 20 / 1 max 0 do (m-key?) if drop (m-key) leave then 20 ms loop ;  
: clear-m-input	( -- )		begin (m-key?) while (m-key) drop repeat ;
: m-type	( adr len )	bounds ?do i c@ m-emit loop ;
: m-expect	( adr len -- n-read )
	0 rot bounds
	?do	m-key dup carret =
		if drop leave else i c! char+ then
	loop ;
: m-open	\ ( n -- flag ) flag:true signals an error
	dup >channel @ if drop true exit then			( n )
	dup use-channel dup 2/ >driver @ swap >channel !	( n )
	init-driver dup
	if channel# off else dtr-on rts-on flush-tx flush-rx then ;

: m-close	( -- )
	channel# @ >channel @ 0= ?exit
	dtr-off rts-off close-driver
	channel# @ >channel off  channel# off ;
: close-drivers	( -- )
	next-driver @ 2* 2 ?do i use-channel m-close loop ;	
\ tools for SerialDev following
: (.serialinfo	( n -- )
	?dup 0= ?exit
	push-decimal
	??cr cr ." Driver: " dup h# 80 + fstr ". dup
	h# c0 +  @ ." , V. " dup h# 10 rshift . h# ffff and .
	cr ." Manufacturer: " dup h# a0 + fstr ".
	cr ." Speeds: " ??cr  h# 100 +
	begin dup @ 0<> while dup @ 8 u.r 0 .tab 4 + repeat drop
	pop-base ;

only forth also definitions modem also
: driver 	\ name ( -- )
	blword load-driver ;
: .channels	( -- )
	??cr next-driver @ 2* 2
	?do i .d i >channel @ if ." used" else ." free" then ." ,   "
	loop ;
: .drivers
	next-driver @ 1 ?do i >driver @ (.serialinfo loop ;
: (cold-hook	(cold-hook init-drivers ; 	' (cold-hook is cold-hook
: (bye		close-drivers (bye ;            ' (bye is bye
