diff --git a/src/dm_tty.f90 b/src/dm_tty.f90 index 16861f1..c649cdd 100644 --- a/src/dm_tty.f90 +++ b/src/dm_tty.f90 @@ -435,21 +435,16 @@ integer function dm_tty_set_attributes(tty) result(rc) !! * `E_INVALID` if TTY is not connected. !! * `E_SYSTEM` if system calls failed. use :: unix + use :: dm_util type(tty_type), intent(inout) :: tty !! TTY type. - integer(kind=c_tcflag_t) :: c_cflag - integer(kind=c_tcflag_t) :: c_iflag - integer(kind=c_tcflag_t) :: c_lflag - integer(kind=c_tcflag_t) :: c_oflag - integer(kind=c_speed_t) :: baud_rate - integer(kind=c_int) :: byte_size - integer(kind=c_int) :: parity - integer(kind=c_int) :: stop_bits + integer(kind=c_int64_t) :: byte_size + integer(kind=c_int64_t) :: parity + integer(kind=c_int64_t) :: stop_bits integer(kind=c_int), target :: stat - type(c_termios) :: termios rc = E_INVALID if (tty%fd < 0) return @@ -540,60 +535,68 @@ integer function dm_tty_set_attributes(tty) result(rc) rc = E_SYSTEM - ! Get current attributes. - stat = c_tcgetattr(tty%fd, termios) - if (stat /= 0) return - - ! Set baud rate (I/O). - stat = c_cfsetispeed(termios, baud_rate); if (stat /= 0) return - stat = c_cfsetospeed(termios, baud_rate); if (stat /= 0) return - - ! Modes. - c_iflag = int(c_uint_to_int(termios%c_iflag), kind=c_tcflag_t) - c_oflag = int(c_uint_to_int(termios%c_oflag), kind=c_tcflag_t) - c_cflag = int(c_uint_to_int(termios%c_cflag), kind=c_tcflag_t) - c_lflag = int(c_uint_to_int(termios%c_lflag), kind=c_tcflag_t) - - ! Input modes. - c_iflag = iand(c_iflag, not(IGNBRK + BRKINT + PARMRK + ISTRIP + INLCR + IGNCR + ICRNL)) ! No special handling of received bytes. - c_iflag = iand(c_iflag, not(IXON + IXOFF + IXANY)) ! Turn XON/XOFF control off. - - ! Output modes. - c_oflag = iand(c_oflag, not(OPOST)) ! No special interpretation of output bytes. - - ! Control modes. - c_cflag = iand(c_cflag, not(CSIZE)) ! Unset byte size. - c_cflag = iand(c_cflag, not(CSTOPB)) ! Unset stop bits. - c_cflag = iand(c_cflag, not(ior(PARENB, PARODD))) ! Unset parity. - c_cflag = ior (c_cflag, byte_size) ! Set byte size. - c_cflag = ior (c_cflag, stop_bits) ! Set stop bits. - c_cflag = ior (c_cflag, parity) ! Set parity. - c_cflag = ior (c_cflag, ior(CLOCAL, CREAD)) ! Ignore modem controls, enable reading. - - ! Local modes. - c_lflag = iand(c_lflag, not(ECHO + ECHOE + ECHONL)) ! No echo. - c_lflag = iand(c_lflag, not(IEXTEN)) ! No implementation-defined input processing. - c_lflag = iand(c_lflag, not(ICANON)) ! No canonical processing. - c_lflag = iand(c_lflag, not(ISIG)) ! No signal chars. - - termios%c_iflag = c_iflag - termios%c_oflag = c_oflag - termios%c_cflag = c_cflag - termios%c_lflag = c_lflag - - if (tty%blocking) then - ! Minimum number of characters for non-canonical read. - termios%c_cc(VMIN) = 1_c_cc_t - termios%c_cc(VTIME) = 0_c_cc_t - else - ! Timeout in deciseconds for non-canonical read. - termios%c_cc(VMIN) = 0_c_cc_t - termios%c_cc(VTIME) = int(max(0, min(255, tty%timeout * 10)), kind=c_cc_t) - end if - - ! Set attributes. - stat = c_tcsetattr(tty%fd, TCSANOW, termios) - if (stat /= 0) return + termios_block: block + integer(kind=c_int64_t) :: c_cflag + integer(kind=c_int64_t) :: c_iflag + integer(kind=c_int64_t) :: c_lflag + integer(kind=c_int64_t) :: c_oflag + type(c_termios) :: termios + + ! Get current attributes. + stat = c_tcgetattr(tty%fd, termios) + if (stat /= 0) return + + ! Set baud rate (I/O). + stat = c_cfsetispeed(termios, baud_rate); if (stat /= 0) return + stat = c_cfsetospeed(termios, baud_rate); if (stat /= 0) return + + ! The joy of working with unsigned integers in Fortran ... + c_iflag = dm_to_signed(termios%c_iflag) + c_oflag = dm_to_signed(termios%c_oflag) + c_cflag = dm_to_signed(termios%c_cflag) + c_lflag = dm_to_signed(termios%c_lflag) + + ! Input modes. + c_iflag = iand(c_iflag, not(int(IGNBRK + BRKINT + PARMRK + ISTRIP + INLCR + IGNCR + ICRNL, kind=c_int64_t))) ! No special handling of received bytes. + c_iflag = iand(c_iflag, not(int(IXON + IXOFF + IXANY, kind=c_int64_t))) ! Turn XON/XOFF control off. + + ! Output modes. + c_oflag = iand(c_oflag, not(int(OPOST, kind=c_int64_t))) ! No special interpretation of output bytes. + + ! Control modes. + c_cflag = iand(c_cflag, not(int(CSIZE, kind=c_int64_t))) ! Unset byte size. + c_cflag = iand(c_cflag, not(int(CSTOPB, kind=c_int64_t))) ! Unset stop bits. + c_cflag = iand(c_cflag, not(int(PARENB + PARODD, kind=c_int64_t))) ! Unset parity. + c_cflag = ior (c_cflag, byte_size) ! Set byte size. + c_cflag = ior (c_cflag, stop_bits) ! Set stop bits. + c_cflag = ior (c_cflag, parity) ! Set parity. + c_cflag = ior (c_cflag, int(CLOCAL + CREAD, kind=c_int64_t)) ! Ignore modem controls, enable reading. + + ! Local modes. + c_lflag = iand(c_lflag, not(int(ECHO + ECHOE + ECHONL, kind=c_int64_t))) ! No echo. + c_lflag = iand(c_lflag, not(int(IEXTEN, kind=c_int64_t))) ! No implementation-defined input processing. + c_lflag = iand(c_lflag, not(int(ICANON, kind=c_int64_t))) ! No canonical processing. + c_lflag = iand(c_lflag, not(int(ISIG, kind=c_int64_t))) ! No signal chars. + + termios%c_iflag = dm_to_unsigned(c_iflag) + termios%c_oflag = dm_to_unsigned(c_oflag) + termios%c_cflag = dm_to_unsigned(c_cflag) + termios%c_lflag = dm_to_unsigned(c_lflag) + + if (tty%blocking) then + ! Minimum number of characters for non-canonical read. + termios%c_cc(VMIN) = 1_c_cc_t + termios%c_cc(VTIME) = 0_c_cc_t + else + ! Timeout in deciseconds for non-canonical read. + termios%c_cc(VMIN) = 0_c_cc_t + termios%c_cc(VTIME) = int(max(0, min(255, tty%timeout * 10)), kind=c_cc_t) + end if + + ! Set attributes. + stat = c_tcsetattr(tty%fd, TCSANOW, termios) + if (stat /= 0) return + end block termios_block ! Set RTS, DTR. if (tty%rts .or. tty%dtr) then diff --git a/src/dm_util.f90 b/src/dm_util.f90 index 58f5e4e..050cd10 100644 --- a/src/dm_util.f90 +++ b/src/dm_util.f90 @@ -9,26 +9,26 @@ module dm_util interface dm_array_has !! Returns whether array contains an integer value. - module procedure :: array_has_i4 - module procedure :: array_has_i8 + module procedure :: array_has_int32 + module procedure :: array_has_int64 end interface interface dm_equals !! Returns whether two real numbers are approximately the same. - module procedure :: equals_r4 - module procedure :: equals_r8 + module procedure :: equals_real32 + module procedure :: equals_real64 end interface interface dm_itoa !! Generic integer to string converter. - module procedure :: i4_to_a - module procedure :: i8_to_a + module procedure :: int32_to_string + module procedure :: int64_to_string end interface interface dm_ftoa !! Generic real to string converter. - module procedure :: f4_to_a - module procedure :: f8_to_a + module procedure :: real32_to_string + module procedure :: real64_to_string end interface interface dm_from_real64 @@ -53,6 +53,12 @@ module dm_util module procedure :: dm_uint32_to_int64 end interface + interface dm_to_unsigned + !! Converts signed integer to unsigned integer. + module procedure :: dm_int32_to_uint16 + module procedure :: dm_int64_to_uint32 + end interface + ! Public procedures. public :: dm_atof public :: dm_atoi @@ -72,37 +78,39 @@ module dm_util public :: dm_rad_to_deg public :: dm_rad_to_gon + public :: dm_to_real64 public :: dm_from_real64 public :: dm_int32_to_real64 public :: dm_int64_to_real64 public :: dm_logical_to_real64 public :: dm_real32_to_real64 - - public :: dm_to_real64 public :: dm_real64_to_int32 public :: dm_real64_to_int64 public :: dm_real64_to_logical public :: dm_real64_to_real32 public :: dm_to_signed + public :: dm_to_unsigned + public :: dm_int32_to_uint16 + public :: dm_int64_to_uint32 public :: dm_uint16_to_int32 public :: dm_uint32_to_int64 ! Private procedures. - private :: array_has_i4 - private :: array_has_i8 + private :: array_has_int32 + private :: array_has_int64 - private :: equals_r4 - private :: equals_r8 + private :: equals_real32 + private :: equals_real64 - private :: f4_to_a - private :: f8_to_a - private :: i4_to_a - private :: i8_to_a + private :: int32_to_string + private :: int64_to_string + private :: real32_to_string + private :: real64_to_string contains ! ****************************************************************** ! PUBLIC PROCEDURES. - ! ****************************************************************** + ! ****************************************************************** pure elemental function dm_atof(str) result(f) !! Converts string to 8-byte real. character(len=*),intent(in) :: str !! Number string. @@ -215,6 +223,59 @@ pure elemental function dm_logical_to_real64(l) result(r) end if end function dm_logical_to_real64 + subroutine dm_sleep(sec) + !! Pauses program execution for given time in seconds. + use :: unix, only: c_useconds_t, c_usleep + integer, intent(in) :: sec !! Delay in seconds [s]. + integer :: rc + + rc = c_usleep(int(sec * 10**6, kind=c_useconds_t)) + end subroutine dm_sleep + + subroutine dm_usleep(usec) + !! Pauses program execution for given time in useconds. + use :: unix, only: c_useconds_t, c_usleep + integer, intent(in) :: usec !! Delay in useconds [us]. + integer :: rc + + rc = c_usleep(int(usec, kind=c_useconds_t)) + end subroutine dm_usleep + + ! ****************************************************************** + ! PUBLIC SIGN FUNCTIONS. + ! ****************************************************************** + pure elemental function dm_int32_to_uint16(s) result(u) + !! Converts signed 4-byte integer to unsigned 2-byte integer. + integer(kind=i4), intent(in) :: s !! Signed integer. + integer(kind=i2) :: u !! Unsigned integer. + + integer(kind=i4) :: i + + i = modulo(s, 65536_i4) + + if (i < 32768_i4) then + u = int(i, kind=i2) + else + u = int(i - 65536_i4, kind=i2) + end if + end function dm_int32_to_uint16 + + pure elemental function dm_int64_to_uint32(s) result(u) + !! Converts signed 8-byte integer to unsigned 4-byte integer. + integer(kind=i8), intent(in) :: s !! Signed integer. + integer(kind=i4) :: u !! Unsigned integer. + + integer(kind=i8) :: i + + i = modulo(s, 4294967296_i8) + + if (i < 2147483648_i8) then + u = int(i, kind=i4) + else + u = int(i - 4294967296_i8, kind=i4) + end if + end function dm_int64_to_uint32 + pure elemental function dm_uint16_to_int32(u) result(s) !! Converts unsigned 2-byte integer to signed 4-byte integer. integer(kind=i2), intent(in) :: u !! Unsigned integer. @@ -239,6 +300,9 @@ pure elemental function dm_uint32_to_int64(u) result(s) end if end function dm_uint32_to_int64 + ! ****************************************************************** + ! PUBLIC REAL TO INTRINSIC TYPE FUNCTIONS. + ! ****************************************************************** pure elemental function dm_real32_to_real64(f) result(r) !! Converts 4-byte real to 8-byte real. real(kind=r4), intent(in) :: f !! 4-byte real value. @@ -280,28 +344,10 @@ pure elemental subroutine dm_real64_to_real32(f, r) r = real(f, kind=r4) end subroutine dm_real64_to_real32 - subroutine dm_sleep(sec) - !! Pauses program execution for given time in seconds. - use :: unix, only: c_useconds_t, c_usleep - integer, intent(in) :: sec !! Delay in seconds [s]. - integer :: rc - - rc = c_usleep(int(sec * 10**6, kind=c_useconds_t)) - end subroutine dm_sleep - - subroutine dm_usleep(usec) - !! Pauses program execution for given time in useconds. - use :: unix, only: c_useconds_t, c_usleep - integer, intent(in) :: usec !! Delay in useconds [us]. - integer :: rc - - rc = c_usleep(int(usec, kind=c_useconds_t)) - end subroutine dm_usleep - ! ****************************************************************** ! PRIVATE PROCEDURES. - ! ****************************************************************** - logical function array_has_i4(array, value) result(has) + ! ****************************************************************** + logical function array_has_int32(array, value) result(has) !! Returns `.true.` if the integer array contains the given value. integer(kind=i4), intent(inout) :: array(:) !! Input array. integer(kind=i4), intent(in) :: value !! Value to search. @@ -309,9 +355,9 @@ logical function array_has_i4(array, value) result(has) has = .false. if (findloc(array, value, dim=1) == 0) return has = .true. - end function array_has_i4 + end function array_has_int32 - logical function array_has_i8(array, value) result(has) + logical function array_has_int64(array, value) result(has) !! Returns `.true.` if the integer array contains the given value. integer(kind=i8), intent(inout) :: array(:) !! Input array. integer(kind=i8), intent(in) :: value !! Value to search. @@ -319,53 +365,28 @@ logical function array_has_i8(array, value) result(has) has = .false. if (findloc(array, value, dim=1) == 0) return has = .true. - end function array_has_i8 + end function array_has_int64 - pure elemental logical function equals_r4(a, b) result(equals) + pure elemental logical function equals_real32(a, b) result(equals) !! Returns `.true.` if the 4-byte real numbers `a` and `b` are !! approximately the same, else `.false.`. real(kind=r4), intent(in) :: a, b equals = abs(a - b) <= epsilon(a) - end function equals_r4 + end function equals_real32 - pure elemental logical function equals_r8(a, b) result(equals) + pure elemental logical function equals_real64(a, b) result(equals) !! Returns `.true.` if the 8-byte real numbers `a` and `b` are !! approximately the same, else `.false.`. real(kind=r8), intent(in) :: a, b equals = abs(a - b) <= epsilon(a) - end function equals_r8 - - pure function f4_to_a(f) result(str) - !! Converts 4-byte real to allocatable string of length > 1. - real(kind=r4), intent(in) :: f !! Value. - character(len=:), allocatable :: str !! String of value. - - character(len=20) :: buf - integer :: stat - - str = '' - write (buf, '(1pg0.12)', iostat=stat) f - if (stat /= 0) return - str = trim(buf) - end function f4_to_a - - pure function f8_to_a(f) result(str) - !! Converts 8-byte real to allocatable string of length > 1. - real(kind=r8), intent(in) :: f !! Value. - character(len=:), allocatable :: str !! String of value. - - character(len=20) :: buf - integer :: stat - - str = '' - write (buf, '(1pg0.12)', iostat=stat) f - if (stat /= 0) return - str = trim(buf) - end function f8_to_a + end function equals_real64 - pure function i4_to_a(i) result(str) + ! ****************************************************************** + ! PRIVATE NUMBER TO STRING FUNCTIONS. + ! ****************************************************************** + pure function int32_to_string(i) result(str) !! Converts 4-byte integer to allocatable string of length > 0. integer, intent(in) :: i !! Value. character(len=:), allocatable :: str !! String of value. @@ -381,9 +402,9 @@ pure function i4_to_a(i) result(str) allocate (character(len=n) :: str) write (str, '(i0)', iostat=stat) i - end function i4_to_a + end function int32_to_string - pure function i8_to_a(i) result(str) + pure function int64_to_string(i) result(str) !! Converts 8-byte integer to allocatable string of length > 0. integer(kind=i8), intent(in) :: i !! Value. character(len=:), allocatable :: str !! String of value. @@ -399,5 +420,33 @@ pure function i8_to_a(i) result(str) allocate (character(len=n) :: str) write (str, '(i0)', iostat=stat) i - end function i8_to_a + end function int64_to_string + + pure function real32_to_string(f) result(str) + !! Converts 4-byte real to allocatable string of length > 1. + real(kind=r4), intent(in) :: f !! Value. + character(len=:), allocatable :: str !! String of value. + + character(len=20) :: buf + integer :: stat + + str = '' + write (buf, '(1pg0.12)', iostat=stat) f + if (stat /= 0) return + str = trim(buf) + end function real32_to_string + + pure function real64_to_string(f) result(str) + !! Converts 8-byte real to allocatable string of length > 1. + real(kind=r8), intent(in) :: f !! Value. + character(len=:), allocatable :: str !! String of value. + + character(len=20) :: buf + integer :: stat + + str = '' + write (buf, '(1pg0.12)', iostat=stat) f + if (stat /= 0) return + str = trim(buf) + end function real64_to_string end module dm_util