\ serialhi    11/15/97   gwj
\ a gpairs-based serial module
require gpairs
require serial

pair#: ser-open
unique.constant  serError
variable serLastErr
: serLastErr@ ( -- err ) serLastErr @ ;

: ?serError   ( err -- )
    dup serLastErr !   serError ?regroup
   ;

ser-open gpair{: serial{ serOpen
ser-open }gpair: }serial serClose

\ change byte orders
: bswap  ( n -- n' )  
    256 /mod swap 8 lshift or ;
: dwswap   ( ud -- ud' ) 
   bswap swap bswap ;

\ close serial port no matter how
\ many opens are outstanding
: serForceClose   ( -- )
    begin  serClose 776 <> until ;

2variable (serShortBuff)
\ get character from serial port
: serC@   ( -- c )
    (serShortBuff) 1 serRecv10
    ?serError (serShortBuff) c@
   ;
   
\ send character to serial port
: serC!   ( c -- )
    (serShortBuff) c!
    (serShortBuff) 1 serSend10
    ?serError
   ;
   
\ get cell from serial port
: ser@   ( -- n ) 
    (serShortBuff) 1 cells serRecv10
    ?serError (serShortBuff) @
   ;
   
\ send cell to serial port
: ser!   ( n -- ) 
    (serShortBuff) !
    (serShortBuff) 1 cells serSend10
    ?serError
   ;
   
\ get double from serial port
: ser2@   ( -- d ) 
    (serShortBuff) 2 cells serRecv10
    ?serError (serShortBuff) 2@
   ;
   
\ send double to serial port
: ser2!   ( d -- ) 
    (serShortBuff) 2!
    (serShortBuff) 2 cells serSend10
    ?serError
   ;
   
\ words for accessing serial settings
serSettings: serCurrSettings>

\ define serial settings @ words
: serSetg@:   ( ; name fld -- )
    create ' , does> >r
    serCurrSettings> dup
    serGetSettings  ?serError
    r> perform 2@
  ;

\ get current baud rate as a double
serSetg@: serBaud@ }serSet.baud}
   ( -- dbaud )

\ get the current serial flags
serSetg@: serFlags@  }serSet.flags}
  ( -- dflags )

\ get the current CTS timeout value
serSetg@: serCtsTO@ }serSet.ctsTO}
  ( -- dtimeout )

\ define serial settings ! words
: serSetg!:   ( ; name fld -- )
    create ' , does> >r
    serCurrSettings> dup
    serGetSettings  ?serError
    tuck r> perform 2!
    serSetSettings  ?serError
  ;

\ set current baud rate as a double
serSetg!: serBaud! }serSet.baud}
   ( dbaud -- )

\ set the current serial flags
serSetg!: serFlags!  }serSet.flags}
  ( dflags -- )

\ set the current CTS timeout value
serSetg!: serCtsTO! }serSet.ctsTO}
  ( dtimeout -- )