utils.f90

! This file is part of mctc-lib.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

module mctc_io_utils
   use mctc_env_accuracy, only : wp
   use mctc_env_error, only : error_type, fatal_error
   implicit none
   private

   public :: getline, next_line
   public :: token_type, next_token, read_token, read_next_token
   public :: io_error, io2_error
   public :: filename, to_string
   public :: to_lower


   !> Text token
   type :: token_type
      !> Begin of sequence
      integer :: first
      !> End of sequence
      integer :: last
   end type token_type


   interface read_token
      module procedure :: read_token_int
      module procedure :: read_token_real
   end interface read_token

   interface read_next_token
      module procedure :: read_next_token_int
      module procedure :: read_next_token_real
   end interface read_next_token


contains


subroutine getline(unit, line, iostat, iomsg)

   !> Formatted IO unit
   integer, intent(in) :: unit

   !> Line to read
   character(len=:), allocatable, intent(out) :: line

   !> Status of operation
   integer, intent(out) :: iostat

   !> Error message
   character(len=:), allocatable, intent(out), optional :: iomsg

   integer, parameter :: bufsize = 512
   character(len=bufsize) :: buffer
   character(len=bufsize) :: msg
   integer :: size
   integer :: stat

   allocate(character(len=0) :: line)
   do
      read(unit, "(a)", advance="no", iostat=stat, iomsg=msg, size=size) &
         & buffer
      if (stat > 0) exit
      line = line // buffer(:size)
      if (stat < 0) then
         if (is_iostat_eor(stat)) then
            stat = 0
         end if
         exit
      end if
   end do

   if (stat /= 0) then
      if (present(iomsg)) iomsg = trim(msg)
   end if
   iostat = stat

end subroutine getline


!> Convenience function to read a line and update associated descriptors
subroutine next_line(unit, line, pos, lnum, iostat, iomsg)

   !> Formatted IO unit
   integer, intent(in) :: unit

   !> Line to read
   character(len=:), allocatable, intent(out) :: line

   !> Current position in line
   integer, intent(out) :: pos

   !> Current line number
   integer, intent(inout) :: lnum

   !> Status of operation
   integer, intent(out) :: iostat

   !> Error message
   character(len=:), allocatable, intent(out), optional :: iomsg

   pos = 0
   call getline(unit, line, iostat, iomsg)
   if (iostat == 0) lnum = lnum + 1
end subroutine next_line


!> Advance pointer to next text token
subroutine next_token(string, pos, token)

   !> String to check
   character(len=*), intent(in) :: string

   !> Current position in string
   integer, intent(inout) :: pos

   !> Token found
   type(token_type), intent(out) :: token

   integer :: start

   if (pos >= len(string)) then
      token = token_type(len(string)+1, len(string)+1)
      return
   end if

   do while(pos < len(string))
      pos = pos + 1
      select case(string(pos:pos))
      case(" ", achar(9), achar(10), achar(13))
         continue
      case default
         exit
      end select
   end do

   start = pos

   do while(pos < len(string))
      pos = pos + 1
      select case(string(pos:pos))
      case(" ", achar(9), achar(10), achar(13))
         pos = pos - 1
         exit
      case default
         continue
      end select
   end do

   token = token_type(start, pos)
end subroutine next_token


function filename(unit)
   integer, intent(in) :: unit
   character(len=:), allocatable :: filename

   character(len=512) :: buffer
   logical :: opened

   filename = "(input)"
   if (unit /= -1) then
      buffer = ""
      inquire(unit=unit, opened=opened, name=buffer)
      if (opened .and. len_trim(buffer) > 0) then
         filename = trim(buffer)
      end if
   end if
end function filename


!> Create new IO error
subroutine io_error(error, message, source, token, filename, line, label)

   !> Error handler
   type(error_type), allocatable, intent(out) :: error

   !> Main error message
   character(len=*), intent(in) :: message

   !> String representing the offending input
   character(len=*), intent(in) :: source

   !> Last processed token
   type(token_type), intent(in) :: token

   !> Name of the input file
   character(len=*), intent(in), optional :: filename

   !> Line number
   integer, intent(in), optional :: line

   !> Label of the offending statement
   character(len=*), intent(in), optional :: label

   character(len=*), parameter :: nl = new_line("a")
   integer :: offset, lnum, width
   character(len=:), allocatable :: string

   lnum = 1
   if (present(line)) lnum = line
   offset = integer_width(lnum)
   width = token%last - token%first + 1

   ! Fix print alignment for empty files
   if (offset == 0) offset = 1

   string = "Error: " // message

   if (present(filename)) then
      string = string // nl // &
         repeat(" ", offset)//"--> "//filename

      string = string // ":" // to_string(lnum)
      if (token%first > 0 .and. token%last >= token%first) then
         string = string // &
            ":"//to_string(token%first)
         if (token%last > token%first) string = string//"-"//to_string(token%last)
      end if
   end if

   string = string // nl //&
      repeat(" ", offset+1)//"|"//nl//&
      to_string(lnum)//" | "//source//nl//&
      repeat(" ", offset+1)//"|"//repeat(" ", token%first)//repeat("^", width)

   if (present(label)) then
      string = string // " " // label
   end if

   string = string // nl //&
      repeat(" ", offset+1)//"|"

   call fatal_error(error, string)
end subroutine io_error


!> Create new IO error
subroutine io2_error(error, message, source1, source2, token1, token2, filename, &
      & line1, line2, label1, label2)

   !> Error handler
   type(error_type), allocatable, intent(out) :: error

   !> Main error message
   character(len=*), intent(in) :: message

   !> String representing the offending input
   character(len=*), intent(in) :: source1, source2

   !> Last processed token
   type(token_type), intent(in) :: token1, token2

   !> Name of the input file
   character(len=*), intent(in), optional :: filename

   !> Line number
   integer, intent(in), optional :: line1, line2

   !> Label of the offending statement
   character(len=*), intent(in), optional :: label1, label2

   character(len=*), parameter :: nl = new_line("a")
   integer :: offset, lnum1, lnum2, width1, width2
   character(len=:), allocatable :: string

   lnum1 = 1
   lnum2 = 1
   if (present(line1)) lnum1 = line1
   if (present(line2)) lnum2 = line2
   offset = integer_width(max(lnum1, lnum2))
   width1 = token1%last - token1%first + 1
   width2 = token2%last - token2%first + 1

   string = "Error: " // message

   if (present(filename)) then
      string = string // nl // &
         repeat(" ", offset)//"--> "//filename

      string = string // ":" // to_string(lnum2)
      if (token2%first > 0 .and. token2%last >= token2%first) then
         string = string // &
            ":"//to_string(token2%first)
         if (token2%last > token2%first) string = string//"-"//to_string(token2%last)
      end if
   end if

   string = string // nl //&
      repeat(" ", offset+1)//"|"//nl//&
      to_string(lnum1, offset)//" | "//source1//nl//&
      repeat(" ", offset+1)//"|"//repeat(" ", token1%first)//repeat("-", width1)

   if (present(label1)) then
      string = string // " " // label1
   end if

   string = string // nl //&
      repeat(" ", offset+1)//":"//nl//&
      to_string(lnum2)//" | "//source2//nl//&
      repeat(" ", offset+1)//"|"//repeat(" ", token2%first)//repeat("^", width2)

   if (present(label2)) then
      string = string // " " // label2
   end if

   string = string // nl //&
      repeat(" ", offset+1)//"|"

   call fatal_error(error, string)
end subroutine io2_error


pure function integer_width(input) result(width)
   integer, intent(in) :: input
   integer :: width

   integer :: val

   val = input
   width = 0
   do while (val /= 0)
      val = val / 10
      width = width + 1
   end do

end function integer_width


!> Represent an integer as character sequence.
pure function to_string(val, width) result(string)
   integer, intent(in) :: val
   integer, intent(in), optional :: width
   character(len=:), allocatable :: string
   integer, parameter :: buffer_len = range(val)+2
   character(len=buffer_len) :: buffer
   integer :: pos
   integer :: n
   character(len=1), parameter :: numbers(0:9) = &
      ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"]

   if (val == 0) then
      if (present(width)) then
         string = repeat(" ", width-1) // numbers(0)
      else
         string = numbers(0)
      end if
      return
   end if

   n = abs(val)
   buffer = ""

   pos = buffer_len + 1
   do while (n > 0)
      pos = pos - 1
      buffer(pos:pos) = numbers(mod(n, 10))
      n = n/10
   end do
   if (val < 0) then
      pos = pos - 1
      buffer(pos:pos) = "-"
   end if

   if (present(width)) then
      string = repeat(" ", max(width-(buffer_len+1-pos), 0)) // buffer(pos:)
   else
      string = buffer(pos:)
   end if
end function to_string


subroutine read_next_token_int(line, pos, token, val, iostat, iomsg)
   character(len=*), intent(in) :: line
   integer, intent(inout) :: pos
   type(token_type), intent(inout) :: token
   integer, intent(out) :: val
   integer, intent(out) :: iostat
   character(len=:), allocatable, intent(out), optional :: iomsg

   call next_token(line, pos, token)
   call read_token(line, token, val, iostat, iomsg)
end subroutine read_next_token_int


subroutine read_token_int(line, token, val, iostat, iomsg)
   character(len=*), intent(in) :: line
   type(token_type), intent(in) :: token
   integer, intent(out) :: val
   integer, intent(out) :: iostat
   character(len=:), allocatable, intent(out), optional :: iomsg

   character(len=512) :: msg

   if (token%first > 0 .and. token%last <= len(line)) then
      val = 0
      read(line(token%first:token%last), *, iostat=iostat, iomsg=msg) val
      if (iostat /= 0) val = 0
   else
      iostat = 1
      msg = "No input found"
   end if
   if (present(iomsg)) iomsg = trim(msg)
end subroutine read_token_int


subroutine read_next_token_real(line, pos, token, val, iostat, iomsg)
   character(len=*), intent(in) :: line
   integer, intent(inout) :: pos
   type(token_type), intent(inout) :: token
   real(wp), intent(out) :: val
   integer, intent(out) :: iostat
   character(len=:), allocatable, intent(out), optional :: iomsg

   call next_token(line, pos, token)
   call read_token(line, token, val, iostat, iomsg)
end subroutine read_next_token_real


subroutine read_token_real(line, token, val, iostat, iomsg)
   character(len=*), intent(in) :: line
   type(token_type), intent(in) :: token
   real(wp), intent(out) :: val
   integer, intent(out) :: iostat
   character(len=:), allocatable, intent(out), optional :: iomsg

   character(len=512) :: msg

   if (token%first > 0 .and. token%last <= len(line)) then
      val = 0.0_wp
      read(line(token%first:token%last), *, iostat=iostat, iomsg=msg) val
      if (iostat /= 0) val = 0.0_wp
   else
      iostat = 1
      msg = "No input found"
   end if
   if (present(iomsg)) iomsg = trim(msg)
end subroutine read_token_real


!> Convert input string to lowercase
elemental function to_lower(str) result(lcstr)

   !> Input string
   character(len=*), intent(in) :: str

   !> Lowercase version of string
   character(len=len(str)):: lcstr

   integer :: ilen, iquote, i, iav, iqc
   integer, parameter :: offset = iachar("A") - iachar("a")

   ilen = len(str)
   iquote = 0
   lcstr = str

   do i = 1, ilen
      iav = iachar(str(i:i))
      if (iquote == 0 .and. (iav == 34 .or.iav == 39)) then
         iquote = 1
         iqc = iav
         cycle
      end if
      if (iquote == 1 .and. iav==iqc) then
         iquote=0
         cycle
      end if
      if (iquote == 1) cycle
      if (iav >= iachar("A") .and. iav <= iachar("Z")) then
         lcstr(i:i) = achar(iav - offset)
      else
         lcstr(i:i) = str(i:i)
      end if
   end do

end function to_lower


end module mctc_io_utils