Patch title: Release 93 bulk changes
Abstract:
File: /language/stream/serial.pli
Key:
    Removed line
    Added line
# Copyright  Thomas Bakketun
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

module "ring.pli"

constant trace false
constant restore false
constant wait_minimal_delay 0.01
constant wait_maximal_delay 15
constant debug false

if os_api="linux"
  type os_termios
    field uInt c_iflags
    field uInt c_oflags
    field uInt c_cflags
    field uInt c_lflags
    field uInt8 c_line
    field (Array uInt8 32) c_cc

  function tcflush fd queue
    arg Int fd queue
    external os_libc_filename "tcflush"

  function tcgetattr fd ios
    arg Int fd ; arg_w os_termios ios
    external os_libc_filename "tcgetattr"

  function tcsetattr fd options ios -> err
    arg Int fd options err ; arg os_termios ios
    external os_libc_filename "tcsetattr"

  function octal d -> o
    arg Intn d ; arg uInt o
    if d<10
      o := d
    else
      o := 8*(octal d\10)+d%10

  # c_cc characters
  constant VINTR 0
  constant VQUIT 1
  constant VERASE 2
  constant VKILL 3
  constant VEOF 4
  constant VTIME 5
  constant VMIN 6
  constant VSWTC 7
  constant VSTART 8
  constant VSTOP 9
  constant VSUSP 10
  constant VEOL 11
  constant VREPRINT 12
  constant VDISCARD 13
  constant VWERASE 14
  constant VLNEXT 15
  constant VEOL2 16

  # c_iflag bits
  constant IGNBRK  octal:0000001
  constant BRKINT  octal:0000002
  constant IGNPAR  octal:0000004
  constant PARMRK  octal:0000010
  constant INPCK   octal:0000020
  constant ISTRIP  octal:0000040
  constant INLCR   octal:0000100
  constant IGNCR   octal:0000200
  constant ICRNL   octal:0000400
  constant IUCLC   octal:0001000
  constant IXON    octal:0002000
  constant IXANY   octal:0004000
  constant IXOFF   octal:0010000
  constant IMAXBEL octal:0020000

  # c_oflag bits
  constant OPOST   octal:0000001
  constant OLCUC   octal:0000002
  constant ONLCR   octal:0000004
  constant OCRNL   octal:0000010
  constant ONOCR   octal:0000020
  constant ONLRET  octal:0000040
  constant OFILL   octal:0000100
  constant OFDEL   octal:0000200
  constant NLDLY   octal:0000400
  constant   NL0   octal:0000000
  constant   NL1   octal:0000400
  constant CRDLY   octal:0003000
  constant   CR0   octal:0000000
  constant   CR1   octal:0001000
  constant   CR2   octal:0002000
  constant   CR3   octal:0003000
  constant TABDLY  octal:0014000
  constant   TAB0  octal:0000000
  constant   TAB1  octal:0004000
  constant   TAB2  octal:0010000
  constant   TAB3  octal:0014000
  constant   XTABS octal:0014000
  constant BSDLY   octal:0020000
  constant   BS0   octal:0000000
  constant   BS1   octal:0020000
  constant VTDLY   octal:0040000
  constant   VT0   octal:0000000
  constant   VT1   octal:0040000
  constant FFDLY   octal:0100000
  constant   FF0   octal:0000000
  constant   FF1   octal:0100000

  # c_cflag bit meaning
  constant CBAUD    octal:0010017
  constant  B0      octal:0000000
  constant  B50     octal:0000001
  constant  B75     octal:0000002
  constant  B110    octal:0000003
  constant  B134    octal:0000004
  constant  B150    octal:0000005
  constant  B200    octal:0000006
  constant  B300    octal:0000007
  constant  B600    octal:0000010
  constant  B1200   octal:0000011
  constant  B1800   octal:0000012
  constant  B2400   octal:0000013
  constant  B4800   octal:0000014
  constant  B9600   octal:0000015
  constant  B19200  octal:0000016
  constant  B38400  octal:0000017
  constant EXTA     B19200
  constant EXTB     B38400
  constant CSIZE    octal:0000060
  constant   CS5    octal:0000000
  constant   CS6    octal:0000020
  constant   CS7    octal:0000040
  constant   CS8    octal:0000060
  constant CSTOPB   octal:0000100
  constant CREAD    octal:0000200
  constant PARENB   octal:0000400
  constant PARODD   octal:0001000
  constant HUPCL    octal:0002000
  constant CLOCAL   octal:0004000
  constant CBAUDEX  octal:0010000
  constant  B57600  octal:0010001
  constant  B115200 octal:0010002
  constant  B230400 octal:0010003
  constant  B460800 octal:0010004
  constant CIBAUD   octal:002003600000n
  constant CRTSCTS  octal:020000000000n

  # c_lflag bits
  constant ISIG    octal:0000001
  constant ICANON  octal:0000002
  constant XCASE   octal:0000004
  constant ECHO    octal:0000010
  constant ECHOE   octal:0000020
  constant ECHOK   octal:0000040
  constant ECHONL  octal:0000100
  constant NOFLSH  octal:0000200
  constant TOSTOP  octal:0000400
  constant ECHOCTL octal:0001000
  constant ECHOPRT octal:0002000
  constant ECHOKE  octal:0004000
  constant FLUSHO  octal:0010000
  constant PENDIN  octal:0040000
  constant IEXTEN  octal:0100000

  # tcflow() and TCXONC use these
  constant TCOOFF 0
  constant TCOON  1
  constant TCIOFF 2
  constant TCION  3

  # tcflush() and TCFLSH use these
  constant TCIFLUSH  0
  constant TCOFLUSH  1
  constant TCIOFLUSH 2

  # tcsetattr uses these
  constant TCSANOW   0
  constant TCSADRAIN 1
  constant TCSAFLUSH 2
eif os_api="win32"
  constant EVENPARITY   2 
  constant MARKPARITY   3
  constant NOPARITY     0
  constant ODDPARITY    1
  constant SPACEPARITY  4

  # DCB:flags
  constant BINARY                1*2^0   # binary mode, no EOF check
  constant PARITY                1*2^1   # enable parity checking
  constant OUTX_CTS_FLOW         1*2^2   # CTS output flow control
  constant OUTX_DSR_FLOW         1*2^3   # DSR output flow control
  constant DTR_CONTROL_DISABLE   0*2^4   # DTR flow control type (values may be wrong)
  constant DTR_CONTROL_ENABLE    1*2^4
  constant DTR_CONTROL_HANDSHAKE 2*2^4
  constant DSR_SENSITIVITY       1*2^6   # DSR sensitivity
  constant TX_CONTINUE_ON_XOFF   1*2^7   # XOFF continues Tx
  constant OUTX                  1*2^8   # XON/XOFF out flow control
  constant INX                   1*2^9   # XON/XOFF in flow control
  constant ERROR_CHAR            1*2^10  # enable error replacement
  constant NULL                  1*2^11  # enable null stripping
  constant RTS_CONTROL_DISABLE   0*2^12  # RTS flow control (values may be wrong)
  constant RTS_CONTROL_ENABLE    1*2^12
  constant RTS_CONTROL_HANDSHAKE 2*2^12
  constant RTS_CONTROL_TOGGLE    3*2^12
  constant ABORT_ON_ERROR        1*2^14  # abort on error
  type DCB
    field uInt32 DCBlength         # sizeof(DCB)
    field uInt32 BaudRate          # current baud rate
    field uInt32 flags
    field uInt16 wReserved         # not currently used
    field uInt16 XonLim            # transmit XON threshold
    field uInt16 XoffLim           # transmit XOFF threshold
    field uInt8 ByteSize           # number of bits/byte, 4-8
    field uInt8 Parity             # 0-4=no,odd,even,mark,space
    field uInt8 StopBits           # 0,1,2 = 1, 1.5, 2
    field uInt8 XonChar            # Tx and Rx XON character
    field uInt8 XoffChar           # Tx and Rx XOFF character
    field uInt8 ErrorChar          # error replacement character
    field uInt8 EofChar            # end of input character
    field uInt8 EvtChar            # received event character
    field uInt16 wReserved1        # reserved do not use

  function os_GetCommState handle dcb -> status
    arg Int handle ; arg_w DCB dcb ; arg CBool status
    external "kernel32.dll" "GetCommState"

  function os_SetCommState handle dcb -> status
    arg Int handle ; arg_w DCB dcb ; arg CBool status
    external "kernel32.dll" "SetCommState"

  type CommTimeouts 
    field Int32 ReadIntervalTimeout
    field Int32 ReadTotalTimeoutMultiplier
    field Int32 ReadTotalTimeoutConstant
    field Int32 WriteTotalTimeoutMultiplier
    field Int32 WriteTotalTimeoutConstant
  
  function os_GetCommTimeouts handle timeouts -> status
    arg Int handle ; arg_w CommTimeouts timeouts ; arg CBool status
    external "kernel32.dll" "GetCommTimeouts"

  function os_SetCommTimeouts handle timeouts -> status
    arg Int handle ; arg_w CommTimeouts timeouts; arg CBool status
    external "kernel32.dll" "SetCommTimeouts"

#----------------------------------------------------------------


type SerialFileSystem
  void
FileSystem maybe SerialFileSystem


type SerialStreamDriver
  field Int fd
  field Float timeout
  if os_api="linux" and restore
    field os_termios ios
StreamDriver maybe SerialStreamDriver


#----------------------------------------------------------------


method drv read buf mini maxi -> red
  oarg_rw SerialStreamDriver drv ; arg Address buf ; arg Int mini maxi red
  if os_api="linux"
    red := os_read drv:fd buf maxi
    if red=(-os_EAGAIN) and drv:timeout=defined
      # should use select or poll
      var DateTime dt := datetime ; var Int lap := 0 ; var Float delay := wait_minimal_delay
      while red=(-os_EAGAIN) and (lap=0 or datetime:seconds-dt:seconds<drv:timeout)
        if trace
          console "."
        sleep delay
        lap += 1
        if delay<drv:timeout/8 and delay<wait_maximal_delay
          delay *= 2
        red := os_read drv:fd buf mini
    red := max red 0
    if trace
      for (var Int i) 0 red-1
        console "r"+string:(cast ((buf translate uInt8 i) map uInt8) uInt)
      console "[lf]"
  eif os_api="win32"
    if not (os_ReadFile drv:fd buf maxi red null)
      red := 0
  else
    error "not implemented under "+os_api

method drv write buf mini maxi -> written
  oarg_rw SerialStreamDriver drv ; arg Address buf ; arg Int mini maxi written
  if os_api="linux"
    written := os_write drv:fd buf maxi
    if written=(-os_EAGAIN) and drv:timeout=defined
      var DateTime dt := datetime ; var Int lap := 0 ; var Float delay := wait_minimal_delay
      while written=(-os_EAGAIN) and (lap=0 or datetime:seconds-dt:seconds<drv:timeout)
        if trace
          console "."
        sleep delay
        lap += 1
        if delay<drv:timeout/8 and delay<wait_maximal_delay
          delay *= 2
        written := os_write drv:fd buf mini
    written := max written 0
    if trace
      for (var Int i) 0 written-1
        console "w"+string:(cast ((buf translate uInt8 i) map uInt8) uInt)
      console "[lf]"
  eif os_api="win32"
    if not (os_WriteFile drv:fd buf maxi written null)
      written := 0
  else
    error "not implemented under "+os_api

method drv flush level -> status
  oarg_rw SerialStreamDriver drv ; arg Int level ; arg Status status
  if os_api="linux"
    status := success
  eif os_api="win32"
    status := success
  else
    error "not implemented under "+os_api

method drv close -> status
  oarg_rw SerialStreamDriver drv ; arg ExtendedStatus status
  if os_api="linux"
    if restore
      tcsetattr drv:fd TCSAFLUSH drv:ios
    status := shunt (os_close drv:fd)=0 success failure
  eif os_api="win32"
    status := shunt (os_CloseHandle drv:fd) success failure
  else
    error "not implemented under "+os_api

method drv configure command stream -> status
  oarg_rw SerialStreamDriver drv ; arg Str command ; arg_rw Stream stream ; arg ExtendedStatus status
  if os_api="linux"
    if (command parse word:"timeout" drv:timeout)
      os_fcntl drv:fd os_F_SETFL (shunt drv:timeout=defined os_O_NONBLOCK 0)
      status := success
    else
      status := failure
  eif os_api="win32"
    if (command parse word:"timeout" drv:timeout)
      console "timeout: " drv:timeout eol
      var CommTimeouts to
      if (os_GetCommTimeouts drv:fd to)
        to ReadIntervalTimeout := 0
        if drv:timeout=defined
          to ReadTotalTimeoutConstant := cast (drv:timeout * 1000) Int
          to WriteTotalTimeoutConstant := cast (drv:timeout * 1000) Int
        else
          to ReadTotalTimeoutConstant := 0
          to WriteTotalTimeoutConstant := 0
        if (os_SetCommTimeouts drv:fd to)
          return success
    return failure
  else
    error "not implemented under "+os_api

#----------------------------------------------------------------


method fs open name options flags stream support -> status
  oarg_rw SerialFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
  var Int port speed databits stopbits
  var Str parity flowcontrol

  if not (name parse port)
    return failure
  if os_api="linux"
    var Str device
    if (name parse port)
      device := "ttyS"+string:port
    else
      device := name
  else
    if not (name parse port)
      return failure
  speed := options option "speed" Int
  if speed=undefined
    speed := options option "baud" Int # just to be backwards compatible
  databits := options option "databits" Int 8
  parity := options option "parity" Str
  stopbits := options option "stopbits" Int 1
  flowcontrol := options option "flowcontrol" Str
  if speed=undefined
    return failure
  if os_api="linux"
    var Int mode
    if (flags .and. in_out)=in
      mode := os_O_RDONLY
    else
      mode := os_O_RDWR
    var Int handle := os_open "/dev/ttyS"+string:port mode+os_O_NOCTTY+os_O_NONBLOCK 6*8*8+6*8+6
    var Int handle := os_open "/dev/"+device mode+os_O_NOCTTY+os_O_NONBLOCK 6*8*8+6*8+6
    # var Int handle := os_open "/dev/ttyS"+string:port mode+os_O_NOCTTY 0
    if handle<0
      return failure
    if restore
      var os_termios old
      tcgetattr handle old
    var os_termios ios
    memory_clear addressof:ios os_termios:size
    ios c_iflags := 0
    ios c_oflags := 0
    ios c_cflags := HUPCL + CREAD
    if (flags .and. nocache)<>nocache
      ios c_lflags := ICANON
    ios:c_cc VTIME := 0 # timeout in 1/10s
    ios:c_cc VMIN := 1 # minimum number of characters to be received

    # speed
    if debug
      console "speed " speed " bauds" eol
    var Int b := undefined
    for (var Int i) 11 15
      if speed=2400*2^(i-11)
        b := i
    for (var Int i) 1 4
      if speed=28800*2^i
        b := CBAUDEX+i
    if b=undefined
      return failure
    ios c_cflags += b

    # databits
    if debug
      console "data bits: " databits eol
    ios c_cflags += shunt databits=5 CS5 databits=6 CS6 databits=7 CS7 CS8

    # parity
    if debug
      console "parity: " parity eol
    if parity="none" or parity=""
      ios c_iflags += IGNPAR
    else
      ios c_iflags += INPCK
      ios c_cflags += PARENB
      if parity="odd"
        ios c_cflags += PARODD

    # stopbits
    if debug
      console "stop bits: " stopbits eol
    if stopbits=2
      ios c_cflags += CSTOPB

    # flowcontrol
    if debug
      console "flow control: " flowcontrol eol
    if flowcontrol="software" or flowcontrol="both"
      ios c_iflags += IXON + IXOFF
    if flowcontrol="hardware" or flowcontrol="both" or flowcontrol=""
      ios c_cflags += CRTSCTS
    else
      ios c_cflags += CLOCAL

    var Int err := tcsetattr handle TCSAFLUSH ios
    if err<>0
      console "failed to set serial line "+string:port+" : error "+string:err+"[lf]"
      console "failed to set serial line "+device+" : error "+string:err+"[lf]"
    os_fcntl handle os_F_SETFL 0
    var Link:SerialStreamDriver drv :> new SerialStreamDriver
    drv fd := handle
    drv timeout := undefined
    if restore
      drv ios := old
    stream stream_driver :> drv
    status := success
  eif os_api="win32"
    var uInt access := (shunt (flags .and. in)<>0 os_GENERIC_READ 0) .or. (shunt (flags .and. out)<>0 os_GENERIC_WRITE 0)
    var Int handle := os_CreateFile "COM"+string:port access 0 null os_OPEN_EXISTING 0 null 
    if handle<0
      return failure
    
    var DCB dcb
    if not (os_GetCommState handle dcb)
      return failure

    dcb BaudRate := speed
    dcb ByteSize := databits
    dcb StopBits := shunt stopbits=2 2 0 # 0 -> 1 stopbit
    
    dcb flags := BINARY
    
    # parity
    if parity="odd" or parity="even"
      dcb flags += PARITY
      if parity="odd"
        dcb Parity := ODDPARITY
      else
        dcb Parity := EVENPARITY
    else
      dcb Parity := NOPARITY
    
    # flowcontrol
    if flowcontrol="hardware" or flowcontrol="both" or flowcontrol=""
      dcb flags += OUTX_CTS_FLOW + OUTX_DSR_FLOW + DTR_CONTROL_HANDSHAKE + RTS_CONTROL_HANDSHAKE
    if flowcontrol="software" or flowcontrol="both"
      dcb flags += OUTX + INX
    
    if not (os_SetCommState handle dcb)
      return failure

    var Link:SerialStreamDriver drv :> new SerialStreamDriver
    drv fd := handle
    drv timeout := undefined
    if restore
      drv ios := old
    stream stream_driver :> drv
    status := success
  else
    error "Serial port support is not available on "+os_api

gvar SerialFileSystem serial_file_system
pliant_multi_file_system mount "serial:" "" serial_file_system