dc_regex.f90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright (c) 2000-2026 Gtool Development Group. All rights reserved.
!-----------------------------------------------------------------------
module dc_regex
  implicit none
  private
  public:: match
 
  character, save    :: C_ESCAPE = '#'
  integer, parameter :: SYM_EOL = -128
  integer, parameter :: SYM_ANYCHAR = 500
  integer, parameter :: SYM_QUESTION = 501
  integer, parameter :: SYM_PLUS = 502
  integer, parameter :: SYM_STAR = 503
  integer, parameter :: SYM_NORMAL_SET = 520
  integer, parameter :: SYM_REVERSED_SET = 521
  integer, parameter :: SYM_HEADFIX = 540
  integer, parameter :: SYM_TAILFIX = 541
  integer, parameter :: SYM_ISDIGIT = 560
  integer, parameter :: SYM_ISALPHA = 561
  integer, parameter :: SYM_ISWORD = 562
  integer, parameter :: SYM_ISSPACE = 563
  integer, parameter :: SYM_ISXDIGIT = 564
  integer, parameter :: SYM_COUNT_BASE = 1000
 
contains
 
  subroutine preprocess_pattern(pattern, symbols)
    character(len = *), intent(in):: pattern
    integer, intent(out):: symbols(:)
    integer:: i, j, code, imax, j_last_set
    integer:: status, stat_return
    integer, parameter::     &
      & STAT_INIT = 1,       &
      & STAT_ESCAPE = 2,     &
      & STAT_OPEN_SET = 3,   &
      & STAT_IN_SET = 4,     &
      & STAT_HEXADECIMAL = 5
    character:: c
    continue
    status = stat_init
    stat_return = stat_init
    symbols(:) = sym_eol
    j_last_set = 0
    imax = len_trim(pattern)
 
    j = 1
    do, i = 1, imax
      c = pattern(i:i)
      select case(status)
      case(stat_init)
        if (c == c_escape) then
          status = stat_escape
          cycle
        else if (c == "[") then
        symbols(j) = sym_normal_set
        status = stat_open_set
        else if (c == ".") then
        symbols(j) = sym_anychar
        else if (c == "?") then
        symbols(j) = sym_question
        else if (c == "+") then
        symbols(j) = sym_plus
        else if (c == "*") then
        symbols(j) = sym_star
        else if (c == "^" .and. i == 1) then
        symbols(j) = sym_headfix
        else if (c == "$" .and. i == imax) then
        symbols(j) = sym_tailfix
        else
          symbols(j) = ichar(c)
        end if
      case(stat_escape)
        if (c == 'd' .or. c == 'D') then
          symbols(j) = sym_isdigit
        else if (c == 'a' .or. c == 'A') then
        symbols(j) = sym_isalpha
        else if (c == 'w' .or. c == 'W') then
        symbols(j) = sym_isword
        else if (c == 's' .or. c == 'S') then
        symbols(j) = sym_isspace
        else if (c == 'z' .or. c == 'Z') then
        symbols(j) = sym_isxdigit
        else if (c == 'x' .or. c == 'X') then
        symbols(j) = -1
        status = stat_hexadecimal
        cycle
        else
          symbols(j) = ichar(c)
        end if
        status = stat_return
      case(stat_hexadecimal)
        code = index("123456789ABCDEFabcdef", c)
        if (code >= 16) code = code - 6
        if (symbols(j) == -1) then
          symbols(j) = code
          cycle
        else
          symbols(j) = symbols(j) * 16 + code
          status = stat_return
        end if
      case(stat_open_set)
        symbols(j) = sym_count_base
        j_last_set = j
        stat_return = stat_in_set
        if (c == '^') then
          symbols(j - 1) = sym_reversed_set
          status = stat_in_set
        else if (c == c_escape) then
        status = stat_escape
        else
          j = j + 1
          symbols(j) = ichar(c)
          status = stat_in_set
        end if
      case(stat_in_set)
        if (c == ']') then
          symbols(j_last_set) = sym_count_base + j - j_last_set - 1
          stat_return = stat_init
          status = stat_init
          cycle
        else if (c == c_escape) then
        status = stat_escape
        cycle
        else
          symbols(j) = ichar(c)
        end if
      end select
      j = j + 1
    end do
    select case(status)
    case(stat_escape)
      symbols(j) = ichar(' ')
    case(stat_open_set)
      symbols(j) = sym_count_base
    case(stat_in_set)
      symbols(j_last_set) = sym_count_base + j - j_last_set - 1
    end select
  end subroutine preprocess_pattern
 
  recursive subroutine match_here(ipat, text, length)
    integer, intent(in):: ipat(:)
    character(len = *), intent(in):: text
    integer, intent(out):: length
    integer:: s1, s2, remain, i, hitmax, hitcount, hit_at_least
    logical:: normal_hit
    continue
    ! パターンの終わり。空パターンには何でもマッチ
    if (size(ipat) == 0 .or. ipat(1) == sym_eol) then
      length = 0
      return
    end if
    ! パターンの文末固定指示
    if (ipat(1) == sym_tailfix) then
      if (text == "") then
        length = 0
      else
        length = -1
      end if
      return
    end if
    if (len(text) == 0) then
      length = -1
      return
    end if
    ! 1字指定(範囲または1字リテラル)の抽出 ... ipat(s1:s2)
    if (ipat(1) == sym_normal_set) then
      s1 = 3
      s2 = 2 + ipat(2) - sym_count_base
      normal_hit = .true.
    else if (ipat(1) == sym_reversed_set) then
    s1 = 3
    s2 = 2 + ipat(2) - sym_count_base
    normal_hit = .false.
    else
      s1 = 1
      s2 = 1
      normal_hit = .true.
    end if
    ! その次の記号 ipat(s2+1) は量化子か次の1字指定である
    remain = s2 + 2
    select case (ipat(s2 + 1))
    case(sym_star)
      hitmax = len(text)
      hit_at_least = 0
    case(sym_plus)
      hitmax = len(text)
      hit_at_least = 1
    case(sym_question)
      hitmax = 1
      hit_at_least = 0
    case default
      hitmax = 1
      hit_at_least = 1
      remain = s2 + 1
    end select
    ! 現位置以降の1字指定のヒット数を数える
    hitcount = 0
    do, i = 1, hitmax
      if (hit(ipat(s1:s2), text(i:i)) .neqv. normal_hit) then
        exit
      end if
      hitcount = i
    end do
    ! 現位置で無ヒットの場合、ヒットを要するならマッチ失敗
    if (hitcount < hit_at_least) then
      length = -1
      return
    end if
    ! 最長原理: なるべく長くヒットしたものから、残りのマッチする
    ! ものを探す。いわゆる最左最長探索の最長である。
    do, i = 1 + hitcount, 1 + hit_at_least, -1
      call match_here(ipat(remain: ), text(i: ), length)
      if (length >= 0) then
        length = length + i - 1
        return
      end if
    end do
    length = -1
  end subroutine match_here
 
  logical function hit(ipat, c) result(result)
    integer, intent(in)          :: ipat(:)
    character(len=*), intent(in) :: c
    character(len=*), parameter  :: &
      & DIGIT = "0123456789",       &
      & XDIGIT = "ABCDEFabcdef",    &
      & ALPHA = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
    integer:: i
    continue
    do, i = 1, size(ipat)
      select case(ipat(i))
      case(sym_anychar)
        result = .true.
      case(sym_isalpha)
        result = (index(alpha, c) > 0)
      case(sym_isdigit)
        result = (index(digit, c) > 0)
      case(sym_isword)
        result = (index(digit, c) > 0 .or. index(alpha, c) > 0 .or. &
          & c == '_')
      case(sym_isxdigit)
        result = (index(digit, c) > 0 .or. index(xdigit, c) > 0)
      case(sym_isspace)
        result = (c == ' ' .or. (iachar(c) >= 8 .and. iachar(c) <= 13))
      case default
        result = (ipat(i) == ichar(c))
      end select
      if (result) return
    end do
    result = .false.
  end function hit
 
  subroutine match(pattern, text, start, length)
    implicit none
    character(len = *), intent(in)  :: pattern, text
    integer, intent(out)            :: start, length
    integer, allocatable            :: ipattern(:)
    integer                         :: text_length
    continue
    ! 空 pattern は空文字列に適合
    if (len(pattern) <= 0) then
      length = 0
      start = 1
      return
    endif
    ! メタキャラクタの認識
    allocate(ipattern(len(pattern) + 2))
    call preprocess_pattern(pattern, ipattern)
    ! 頭寄せ指定のある場合
    if (ipattern(1) == sym_headfix) then
      start = 1
      call match_here(ipattern(2: ), text, length)
      if (length < 0) goto 995
      goto 999
    end if
    ! 最左原理
    text_length = len(text)
    do, start = 1, text_length + 1
      call match_here(ipattern, text(start:text_length), length)
      if (length >= 0) goto 999
    end do
    ! みつからない場合
995 continue
    start = 0
    length = -1
999 continue
    deallocate(ipattern)
  end subroutine match
 
end module dc_regex