\ Serial communications
\ RiscOS Forthmacs support for SerialDev by Hugo Fiennes
\ V 2.1 26.01.95

vocabulary modem  only forth also system also modem also definitions  decimal

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 task

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 + ;

: 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 > abort" All driverslots used"
	h# 2000 allocate if drop false exit then
	astring astring locals| loadaddress cli-string driver-id |
	base @ hex driver-id (u.) loadaddress pack drop base !
	next-driver @ >drivername "move
	p" LOAD SerialDev:modules." 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= abort" Couldn't load serial driver"
	next-driver @ >driver !
	1 next-driver +! ;
: use-channel	( n -- )
	dup 2 next-driver @ 2* within 0= abort" invalid serial channel"
	channel# ! ;

\ SerialDev driver function call interface using driver-id
: serial-error	true abort" Serial driver not loaded" ;
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 ;

: 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 ;

: 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 pause (m-emit?) until (m-emit) drop ;
: m-key?	( -- flag )	pause (m-key?) 0<> ;
: m-key		( -- char )	begin m-key? until (m-key) ;
: 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! 1+ 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 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
	base @ swap 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
	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