subroutineparse_procedure_header
subroutine parse_procedure_header(line, h)
Read a subroutine or function statement.
Arguments
| Name | Type | Intent | Attributes | Description |
|---|---|---|---|---|
| line | character(len=*) | in | the statement | |
| h | type(procedure_header_t) | out | the result |
Calls
Source
Show the code
subroutine parse_procedure_header(line, h)
character(len=*), intent(in) :: line !! the statement
type(procedure_header_t), intent(out) :: h !! the result
character(len=len(line)) :: low
character(len=:), allocatable :: prefix
character(len=*), parameter :: PREFIXES(*) = [character(len=13) :: 'impure', 'pure', 'elemental', 'non_recursive', &
'recursive', 'module']
integer :: k, at, open, close, depth, n
low = lowercase(line)
allocate (h%attribs(0), h%args(0))
depth = 0
at = 0
do k = 1, len(low)
if (low(k:k) == '(') depth = depth + 1
if (low(k:k) == ')') depth = depth - 1
if (depth /= 0) cycle
if (word_at(low, k, 'subroutine')) then
at = k + 10
exit
end if
if (word_at(low, k, 'function')) then
at = k + 8
h%is_function = .true.
exit
end if
end do
if (at == 0) return
prefix = low(1:at - merge(9, 11, h%is_function))
do k = 1, size(PREFIXES)
n = len_trim(PREFIXES(k))
open = index(prefix, PREFIXES(k) (1:n))
if (open > 0) then
call push(h%attribs, PREFIXES(k) (1:n))
prefix = prefix(:open - 1)//prefix(open + n:)
end if
end do
call original_prefix(line, low, at - merge(8, 10, h%is_function) - 1, h%attribs, prefix)
h%prefix = remove_blanks(prefix)
open = at + verify(line(at:)//'x', ' ') - 1
close = open + verify(low(open:)//' ', 'abcdefghijklmnopqrstuvwxyz0123456789_') - 2
h%name = line(open:close)
open = close + verify(line(close + 1:)//'x', ' ')
close = open - 1
if (open <= len(line)) then
if (line(open:open) == '(') then
close = closing_paren(line, open)
if (close == 0) return
if (close > open + 1) then
if (len(strip(line(open + 1:close - 1))) > 0) h%args = top_split(line(open + 1:close - 1), ',')
end if
end if
end if
do k = close + 1, len(low)
if (word_at(low, k, 'result')) then
open = k + index(low(k:), '(') - 1
at = closing_paren(low, open)
if (at > 0) h%result_name = strip(line(open + 1:at - 1))
else if (word_at(low, k, 'bind')) then
open = k + index(low(k:), '(') - 1
at = closing_paren(low, open)
if (at > 0) h%bind_c = strip(line(open + 1:at - 1))
end if
end do
h%ok = .true.
end subroutine parse_procedure_header