\ serial 99.2.20 7:30 pm NAB
\ based on Wade Johnson's work
needs core-ext
needs zstrings
needs toolkit
needs struct
hex 300 decimal constant serErrorClass
serErrorClass
dup 1 or constant serErrBadParam
dup 2 or constant serErrBadPort
dup 3 or constant serErrNoMem
dup 4 or constant serErrBadConnID
dup 5 or constant serErrTimeOut
dup 6 or constant serErrLineErr
dup 7 or constant serErrAlreadyOpen
dup 8 or constant serErrStillOpen
dup 9 or constant serErrNotOpen
10 or constant serErrNotSupported
hex
1 0 2constant serSetFlagStopBitsM
0 0 2constant serSetFlagStopBits1
1 0 2constant serSetFlagStopBits2
2 0 2constant serSetFlagParityOnM
4 0 2constant serSetFlagParityEvenM
8 0 2constant serSetFlagXonXoffM
10 0 2constant serSetFlagRTSAutoM
20 0 2constant serSetFlagCTSAutoM
C0 0
2constant serSetFlagBitsPerCharM
0 0 2constant serSetFlagBitsPerChar5
40 0
2constant serSetFlagBitsPerChar6
80 0
2constant serSetFlagBitsPerChar7
C0 0
2constant serSetFlagBitsPerChar8
decimal
: 2or ( d1. d2. -- d3. )
rot or rot rot or swap ;
serSetFlagBitsPerChar8
serSetFlagStopBits1 2or
serSetFlagRTSAutoM 2or
2constant serDefaultSettings
500 constant serDefaultCTSTimeout
1 constant serLnErrParity
2 constant serLnErrHWOverrun
4 constant serLnErrFraming
8 constant serLnErrBreak
16 constant serLnErrHShake
32 constant serLnErrSWOverrun
variable SerLib#
variable serErr
\ Iinit the serial library:
: InitSerLib ( -- err )
SerLib# >abs
z" Serial Library" drop >abs
SysLibFind ;
: serSysTrap ( # -- )
SerLib# @ swap systrap drop ;
: serSysTrap2n ( a b # -- n )
serSysTrap 2drop d0 drop ;
: serSysTrap4n ( a b c d # -- n )
serSysTrap 4drop d0 drop ;
: serClearErr ( -- )
43016 serSysTrap ;
: serOpen ( baud. -- err )
0 43009 serSysTrap 3drop d0 drop ;
: serClose ( -- err )
43010 serSysTrap d0 drop ;
\ OS 1.0 send routines
: serSend10A ( &addr. len. -- err )
2swap 43017 serSysTrap4n ;
: str>lstr ( &addr len -- &addr. len. )
>r >abs r> 0 ;
: serSend10 ( &addr len -- err )
str>lstr serSend10A ;
\ OS 2.0 send routines
: serSendA ( &addr. len. -- #. err )
2swap 2>r serErr >abs
2swap 2r>
43031 serSysTrap 4drop
@a d0 rot ;
: serSend ( &addr len -- #. err )
str>lstr serSendA ;
: serSendWait ( -- err )
-1. 43018 serSysTrap2n ;
\ Timeout for receive commands:
2variable SerRecvTO
-1. SerRecvTO 2!
: set-timeout ( timeout. -- )
SerRecvTO 2! ;
: get-timeout ( -- timeout. )
SerRecvTO 2@ ;
\ OS 1.0 receive routines
: serRecv10A ( &addr. len. -- err )
2swap 2>r get-timeout
2swap 2r>
43021 serSysTrap 6drop d0 drop ;
: serRecv10 ( &addr len -- err )
str>lstr serRecv10A ;
\ OS 2.0 receive routines
: serRecvA ( &addr. len. -- #. err )
2swap 2>r 2>r SerErr >abs
get-timeout 2r> 2r>
43032 serSysTrap 6drop @a d0 rot ;
: serRecv ( addr cnt -- #. err )
str>lstr serRecvA ;
2variable templong 0. templong 2!
: serRecvCheck ( -- bytes. err )
tempLong >abs
43023 serSysTrap 2@a d0 drop ;
: serRecvFlush ( -- )
get-timeout
43024 serSysTrap 2drop ;
: serRecvWaitA ( bytes. -- err )
get-timeout 2swap
43023 serSysTrap4n ;
: serRecvWait ( bytes -- err )
0 serRecvWaitA ;
\ warning: bug in OS 2.0
: serSetRecvBuffA
( &addr. len. -- err )
2swap 43025 serSysTrap4n ;
: serSetRecvBuff ( &addr len -- err )
str>lstr serSetRecvBuffA ;
variable ctsOn variable dsrOn
: serGetStatus ( -- cts dsr err )
dsrOn >abs ctsOn >abs
43015 serSysTrap4n
ctsOn c@ dsrOn c@ rot ;
struct
2 cells field serSet.baud
2 cells field serSet.flags
2 cells field serSet.ctsTO
end-struct serSettings:
: serGetSettings ( &settings -- err )
>abs 43013 serSysTrap2n ;
: serSetSettings ( &settings -- err )
>abs 43014 serSysTrap2n ;
: cts? ( -- flag ) (hex) fffff906. @a
1 9 lshift and 0= 0= ;