parse_value_nonrecursive Subroutine

private subroutine parse_value_nonrecursive(json, unit, str, value)

Non-recursive, state-machine based JSON parser.

This is an alternative to the original recursive parse_value_recursive routine. This one uses an explicit stack and state machine to parse JSON without recursion.

Note

This routine is currently experimental and disabled by default. The recursive version remains the default parser.

Arguments

Type IntentOptional Attributes Name
class(json_core), intent(inout) :: json
integer(kind=IK), intent(in) :: unit

file unit number
character(kind=CK, len=*), intent(in) :: str

string containing JSON data
type(json_value), pointer :: value

JSON data that is extracted

Calls

proc~~parse_value_nonrecursive~~CallsGraph proc~parse_value_nonrecursive parse_value_nonrecursive none~add~4 json_core%add proc~parse_value_nonrecursive->none~add~4 none~destroy~3 json_core%destroy proc~parse_value_nonrecursive->none~destroy~3 none~throw_exception json_core%throw_exception proc~parse_value_nonrecursive->none~throw_exception proc~json_value_create json_value_create proc~parse_value_nonrecursive->proc~json_value_create proc~parse_for_chars json_core%parse_for_chars proc~parse_value_nonrecursive->proc~parse_for_chars proc~parse_number json_core%parse_number proc~parse_value_nonrecursive->proc~parse_number proc~parse_string json_core%parse_string proc~parse_value_nonrecursive->proc~parse_string proc~pop_char json_core%pop_char proc~parse_value_nonrecursive->proc~pop_char proc~push_char json_core%push_char proc~parse_value_nonrecursive->proc~push_char proc~to_array json_core%to_array proc~parse_value_nonrecursive->proc~to_array proc~to_logical json_core%to_logical proc~parse_value_nonrecursive->proc~to_logical proc~to_null json_core%to_null proc~parse_value_nonrecursive->proc~to_null proc~to_object json_core%to_object proc~parse_value_nonrecursive->proc~to_object proc~to_string json_core%to_string proc~parse_value_nonrecursive->proc~to_string proc~json_value_add_string_name_ascii json_core%json_value_add_string_name_ascii none~add~4->proc~json_value_add_string_name_ascii proc~json_value_add_string_val_ascii json_core%json_value_add_string_val_ascii none~add~4->proc~json_value_add_string_val_ascii proc~json_value_add_string_vec_name_ascii json_core%json_value_add_string_vec_name_ascii none~add~4->proc~json_value_add_string_vec_name_ascii proc~json_value_add_string_vec_val_ascii json_core%json_value_add_string_vec_val_ascii none~add~4->proc~json_value_add_string_vec_val_ascii proc~destroy_json_core json_core%destroy_json_core none~destroy~3->proc~destroy_json_core proc~json_value_destroy json_core%json_value_destroy none~destroy~3->proc~json_value_destroy proc~json_throw_exception json_core%json_throw_exception none~throw_exception->proc~json_throw_exception proc~wrap_json_throw_exception json_core%wrap_json_throw_exception none~throw_exception->proc~wrap_json_throw_exception proc~parse_for_chars->none~throw_exception proc~parse_for_chars->proc~pop_char proc~parse_number->proc~pop_char proc~parse_number->proc~push_char proc~json_clear_exceptions json_core%json_clear_exceptions proc~parse_number->proc~json_clear_exceptions proc~string_to_dble json_core%string_to_dble proc~parse_number->proc~string_to_dble proc~string_to_int json_core%string_to_int proc~parse_number->proc~string_to_int proc~to_integer json_core%to_integer proc~parse_number->proc~to_integer proc~to_real json_core%to_real proc~parse_number->proc~to_real proc~parse_string->none~throw_exception proc~parse_string->proc~pop_char proc~unescape_string unescape_string proc~parse_string->proc~unescape_string proc~push_char->none~throw_exception proc~integer_to_string integer_to_string proc~push_char->proc~integer_to_string proc~destroy_json_data destroy_json_data proc~to_array->proc~destroy_json_data proc~to_logical->proc~destroy_json_data proc~to_null->proc~destroy_json_data proc~to_object->proc~destroy_json_data proc~to_string->proc~destroy_json_data proc~json_value_add_string_name_ascii->none~add~4 interface~to_unicode to_unicode proc~json_value_add_string_name_ascii->interface~to_unicode proc~json_value_add_string_val_ascii->none~add~4 proc~json_value_add_string_val_ascii->interface~to_unicode proc~json_value_add_string_vec_name_ascii->none~add~4 proc~json_value_add_string_vec_name_ascii->interface~to_unicode proc~json_value_add_string_vec_val_ascii->none~add~4 proc~json_value_add_string_vec_val_ascii->interface~to_unicode proc~json_value_destroy->none~destroy~3 proc~json_value_destroy->proc~destroy_json_data proc~string_to_dble->none~throw_exception proc~string_to_int->none~throw_exception proc~string_to_integer string_to_integer proc~string_to_int->proc~string_to_integer proc~to_integer->proc~destroy_json_data proc~to_real->proc~destroy_json_data proc~valid_json_hex valid_json_hex proc~unescape_string->proc~valid_json_hex proc~wrap_json_throw_exception->none~throw_exception proc~wrap_json_throw_exception->interface~to_unicode proc~to_uni to_uni interface~to_unicode->proc~to_uni proc~to_uni_vec to_uni_vec interface~to_unicode->proc~to_uni_vec

Source Code

    subroutine parse_value_nonrecursive(json, unit, str, value)

    implicit none

    class(json_core),intent(inout)      :: json
    integer(IK),intent(in)              :: unit   !! file unit number
    character(kind=CK,len=*),intent(in) :: str    !! string containing JSON data
    type(json_value),pointer            :: value  !! JSON data that is extracted

    ! Parser states
    integer(IK),parameter :: STATE_INITIAL         = 1
    integer(IK),parameter :: STATE_PARSE_VALUE     = 2
    integer(IK),parameter :: STATE_OBJECT_START    = 3
    integer(IK),parameter :: STATE_OBJECT_KEY      = 4
    integer(IK),parameter :: STATE_OBJECT_COLON    = 5
    integer(IK),parameter :: STATE_OBJECT_VALUE    = 6
    integer(IK),parameter :: STATE_OBJECT_NEXT     = 7
    integer(IK),parameter :: STATE_ARRAY_START     = 8
    integer(IK),parameter :: STATE_ARRAY_VALUE     = 9
    integer(IK),parameter :: STATE_ARRAY_NEXT      = 10
    integer(IK),parameter :: STATE_DONE            = 11

    type parse_stack_entry
        !! Stack entry type for tracking parse context
        integer(IK) :: state = 0_IK                        !! parser state
        type(json_value),pointer :: context => null()      !! current object/array being parsed
        type(json_value),pointer :: current_pair => null() !! current key-value pair (for objects)
        logical(LK) :: expecting_element = .false.         !! for trailing comma detection
    end type parse_stack_entry

    ! Parser stack (local allocatable array, grows as needed)
    type(parse_stack_entry),dimension(:),allocatable :: stack
    integer(IK) :: stack_top       !! current stack depth
    integer(IK) :: stack_capacity  !! current stack allocation size

    logical(LK)              :: eof
    character(kind=CK,len=1) :: c
    integer(IK)              :: current_state
    type(json_value),pointer :: current_value
    type(json_value),pointer :: current_pair
    logical(LK)              :: expecting_element
    logical(LK)              :: done
#if defined __GFORTRAN__
    character(kind=CK,len=:),allocatable :: tmp
#endif

    ! Initialize
    if (json%exception_thrown) return
    if (.not. associated(value)) then
        call json%throw_exception('Error in parse_value_nonrecursive: '//&
                                  'value pointer not associated.')
        return
    end if

    ! Allocate initial stack
    allocate(stack(json%parser_initial_stack_size))
    stack_capacity = json%parser_initial_stack_size
    stack_top = 0
    done = .false.
    current_state = STATE_INITIAL
    current_value => value
    nullify(current_pair)
    expecting_element = .false.

    ! Main parsing loop
    do while (.not. done .and. .not. json%exception_thrown)

        select case (current_state)

        case (STATE_INITIAL)
            ! Read first character to determine value type
            call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
                               skip_comments=json%allow_comments, c=c)
            if (eof) then
                done = .true.
                exit
            end if

            select case (c)
            case (start_object)
                call json%to_object(current_value)
                current_state = STATE_OBJECT_START
            case (start_array)
                call json%to_array(current_value)
                current_state = STATE_ARRAY_START
            case (end_array)
                ! Empty array element - destroy the element and signal via null
                call json%push_char(c)
                if (associated(current_value)) then
                    call json%destroy(current_value)
                    nullify(current_value)
                end if
                ! Update the stack to know element is null
                if (stack_top > 0) then
                    nullify(stack(stack_top)%current_pair)
                end if
                call pop_stack()
            case (quotation_mark)
                call json%to_string(current_value)
#if defined __GFORTRAN__
                ! write to a tmp variable because of
                ! a bug in 4.9 gfortran compiler.
                call json%parse_string(unit,str,tmp)
                current_value%str_value = tmp
                if (allocated(tmp)) deallocate(tmp)
#else
                call json%parse_string(unit,str,current_value%str_value)
#endif
                call pop_stack()
            case (CK_'t') !true_str(1:1) gfortran bug work around
                call json%parse_for_chars(unit, str, true_str(2:))
                if (.not. json%exception_thrown) call json%to_logical(current_value,.true.)
                call pop_stack()
            case (CK_'f') !false_str(1:1) gfortran bug work around
                call json%parse_for_chars(unit, str, false_str(2:))
                if (.not. json%exception_thrown) call json%to_logical(current_value,.false.)
                call pop_stack()
            case (CK_'n')  !null_str(1:1) gfortran bug work around
                call json%parse_for_chars(unit, str, null_str(2:))
                if (.not. json%exception_thrown) call json%to_null(current_value)
                call pop_stack()
            case (CK_'-', CK_'0': CK_'9', CK_'.', CK_'+')
                call json%push_char(c)
                call json%parse_number(unit, str, current_value)
                call pop_stack()
            case default
                call json%throw_exception('Error in parse_value_nonrecursive: '//&
                                          'Unexpected character: "'//c//'"')
                call pop_stack()
            end select

        case (STATE_OBJECT_START)
            ! Start parsing object members
            call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
                               skip_comments=json%allow_comments, c=c)
            if (eof) then
                call json%throw_exception('Error in parse_object:'//&
                                          ' Unexpected end of file while parsing start of object.')
                exit
            else if (c == end_object) then
                ! Empty object or end after trailing comma
                if (expecting_element .and. .not. json%allow_trailing_comma) then
                    call json%throw_exception('Error in parse_object: '//&
                                              'Dangling comma when parsing an object.')
                end if
                call pop_stack()
            else if (c == quotation_mark) then
                ! Start of key
                call json_value_create(current_pair)
#if defined __GFORTRAN__
                ! write to a tmp variable because of
                ! a bug in 4.9 gfortran compiler.
                call json%parse_string(unit,str,tmp)
                current_pair%name = tmp
                if (allocated(tmp)) deallocate(tmp)
#else
                call json%parse_string(unit,str,current_pair%name)
#endif
                current_state = STATE_OBJECT_COLON
            else
                call json%throw_exception('Error in parse_object: Expecting string: "'//c//'"')
                exit
            end if

        case (STATE_OBJECT_COLON)
            ! Expect colon after object key
            call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
                               skip_comments=json%allow_comments, c=c)
            if (eof) then
                call json%throw_exception('Error in parse_object:'//&
                                          ' Unexpected end of file while parsing object member.')
                if (associated(current_pair)) call json%destroy(current_pair)
                exit
            else if (c == colon_char) then
                current_state = STATE_OBJECT_VALUE
            else
                call json%throw_exception('Error in parse_object:'//&
                                          ' Expecting : and then a value: '//c)
                if (associated(current_pair)) call json%destroy(current_pair)
                exit
            end if

        case (STATE_OBJECT_VALUE)
            ! Parse value for current key - push context and parse recursively
            call push_stack(STATE_OBJECT_NEXT, current_value, current_pair, .false.)
            current_value => current_pair
            current_state = STATE_INITIAL
            expecting_element = .false.

        case (STATE_OBJECT_NEXT)
            ! After parsing object value, add the pair to parent and check for comma or end
            if (associated(current_pair)) then
                call json%add(current_value, current_pair)
                nullify(current_pair)
            end if

            call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
                               skip_comments=json%allow_comments, c=c)
            if (eof) then
                call json%throw_exception('Error in parse_object: '//&
                                          'End of file encountered when parsing an object')
                exit
            else if (c == delimiter) then
                expecting_element = .true.
                current_state = STATE_OBJECT_START
            else if (c == end_object) then
                call pop_stack()
            else
                call json%throw_exception('Error in parse_object: Expecting end of object: '//c)
                exit
            end if

        case (STATE_ARRAY_START)
            ! Parse array elements
            nullify(current_pair)
            call json_value_create(current_pair)

            ! Push state to return here after parsing element
            call push_stack(STATE_ARRAY_NEXT, current_value, current_pair, expecting_element)
            current_value => current_pair
            current_state = STATE_INITIAL
            expecting_element = .false.

        case (STATE_ARRAY_NEXT)
            ! After parsing array element, add to parent array
            if (associated(current_pair)) then
                ! current_pair is the element we just parsed, add to parent array
                call json%add(current_value, current_pair)
                nullify(current_pair)
            end if

            call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
                               skip_comments=json%allow_comments, c=c)
            if (eof) then
                call json%throw_exception('Error in parse_array: '//&
                                          'End of file encountered when parsing an array.')
                exit
            else if (c == delimiter) then
                expecting_element = .true.
                current_state = STATE_ARRAY_START
            else if (c == end_array) then
                if (expecting_element .and. .not. json%allow_trailing_comma) then
                    call json%throw_exception('Error in parse_array: '//&
                                              'Dangling comma when parsing an array.')
                end if
                call pop_stack()
            else
                call json%throw_exception('Error in parse_array: '//&
                                          'Unexpected character encountered when parsing array.')
                exit
            end if

        case default
            call json%throw_exception('Error: Invalid parser state')
            exit
        end select

    end do

    ! Cleanup
    if (allocated(stack)) deallocate(stack)

    contains

        subroutine push_stack(return_state, context, pair, expect_elem)
            !! Push current context onto stack
            integer(IK),intent(in) :: return_state
            type(json_value),pointer,intent(in) :: context
            type(json_value),pointer,intent(in) :: pair
            logical(LK),intent(in) :: expect_elem

            type(parse_stack_entry),dimension(:),allocatable :: new_stack

            stack_top = stack_top + 1

            ! Check stack depth limit
            if (stack_top > json%parser_max_stack_size) then
                call json%throw_exception('Error: Maximum parse depth exceeded')
                return
            end if

            ! Grow stack if needed
            if (stack_top > stack_capacity) then
                allocate(new_stack(stack_capacity * 2))
                new_stack(1:stack_capacity) = stack(1:stack_capacity)
                call move_alloc(new_stack, stack)
                stack_capacity = stack_capacity * 2
            end if

            ! Save context
            stack(stack_top)%state = return_state
            stack(stack_top)%context => context
            stack(stack_top)%current_pair => pair
            stack(stack_top)%expecting_element = expect_elem

        end subroutine push_stack

        subroutine pop_stack()
            !! Pop context from stack
            if (stack_top == 0) then
                ! Finished parsing
                done = .true.
                current_state = STATE_DONE
            else
                ! Restore context
                current_state = stack(stack_top)%state
                current_value => stack(stack_top)%context
                current_pair => stack(stack_top)%current_pair
                expecting_element = stack(stack_top)%expecting_element
                stack_top = stack_top - 1
            end if
        end subroutine pop_stack

    end subroutine parse_value_nonrecursive