! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !+PJK Need to convert to autodoc style + usual PROCESS standard layout !----------------------------------------------------------------------------------------- ! ! FSON library ! ! Extracted from https://github.com/josephalevin/fson on 9th July 2014 ! ! with selected updates taken from the version forked as ! ! https://github.com/jmozmoz/fson/commit/b210a9011bb804957546e2a4b6eade578e7035ef ! ! plus some improvements to help with array handling and double precision, by ! P J Knight, 17th July 2014 ! ! Comprises the following original FSON files: ! string.f95, value_m.f95, fson_path_m.f95, fson.f95 ! !----------------------------------------------------------------------------------------- ! ! Copyright (c) 2012 Joseph A. Levin ! ! Permission is hereby granted, free of charge, to any person obtaining a copy of this ! software and associated documentation files (the "Software"), to deal in the Software ! without restriction, including without limitation the rights to use, copy, modify, merge, ! publish, distribute, sublicense, and/or sell copies of the Software, and to permit ! persons to whom the Software is furnished to do so, subject to the following conditions: ! ! The above copyright notice and this permission notice shall be included in all copies or ! substantial portions of the Software. ! ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, ! INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR ! PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT ! OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ! DEALINGS IN THE SOFTWARE. ! !----------------------------------------------------------------------------------------- module fson_string_m private public :: fson_string, fson_string_create, fson_string_destroy, fson_string_length, & fson_string_append, fson_string_clear public :: fson_string_equals, fson_string_copy integer, parameter :: BLOCK_SIZE = 32 type fson_string character (len = BLOCK_SIZE) :: chars integer :: index = 0 type(fson_string), pointer :: next => null() end type fson_string interface fson_string_append module procedure append_chars, append_string end interface interface fson_string_copy module procedure copy_chars end interface interface fson_string_equals module procedure equals_string end interface interface fson_string_length module procedure string_length end interface contains ! ! FSON STRING CREATE ! function fson_string_create(chars) result(new) character(len=*), optional :: chars type(fson_string), pointer :: new allocate(new) ! append chars if available if (present(chars)) then call append_chars(new, chars) end if end function fson_string_create ! ! FSON STRING DESTROY ! recursive subroutine fson_string_destroy(this) type(fson_string), pointer :: this if (associated(this % next)) then call fson_string_destroy(this % next) end if nullify (this % next) nullify (this) end subroutine fson_string_destroy ! ! ALLOCATE BLOCK ! subroutine allocate_block(this) type(fson_string), pointer :: this type(fson_string), pointer :: new if (.not.associated(this % next)) then allocate(new) this % next => new end if end subroutine allocate_block ! ! APPEND_STRING ! subroutine append_string(str1, str2) type(fson_string), pointer :: str1, str2 integer length, i length = string_length(str2) do i = 1, length call append_char(str1, get_char_at(str2, i)) end do end subroutine append_string ! ! APPEND_CHARS ! subroutine append_chars(str, c) type(fson_string), pointer :: str character (len = *), intent(in) :: c integer length, i length = len(c) do i = 1, length call append_char(str, c(i:i)) end do end subroutine append_chars ! ! APPEND_CHAR ! recursive subroutine append_char(str, c) type(fson_string), pointer :: str character, intent(in) :: c if (str % index >= BLOCK_SIZE) then !set down the chain call allocate_block(str) call append_char(str % next, c) else ! set local str % index = str % index + 1 str % chars(str % index:str % index) = c end if end subroutine append_char ! ! COPY CHARS ! subroutine copy_chars(this, to) type(fson_string), pointer :: this character(len = *), intent(inout) :: to integer :: length length = min(string_length(this), len(to)) do i = 1, length to(i:i) = get_char_at(this, i) end do ! pad with nothing do i = length + 1, len(to) to(i:i) = "" end do end subroutine copy_chars ! ! CLEAR ! recursive subroutine string_clear(this) type(fson_string), pointer :: this if (associated(this % next)) then call string_clear(this % next) deallocate(this % next) nullify (this % next) end if this % index = 0 end subroutine string_clear ! ! SIZE ! recursive integer function string_length(str) result(count) type(fson_string), pointer :: str count = str % index if (str % index == BLOCK_SIZE .AND. associated(str % next)) then count = count + string_length(str % next) end if end function string_length ! ! GET CHAR AT ! recursive character function get_char_at(this, i) result(c) type(fson_string), pointer :: this integer, intent(in) :: i if (i <= this % index) then c = this % chars(i:i) else c = get_char_at(this % next, i - this % index) end if end function get_char_at ! ! EQUALS STRING ! logical function equals_string(this, other) result(equals) type(fson_string), pointer :: this, other integer :: i equals = .false. if (fson_string_length(this) /= fson_string_length(other)) then equals = .false. return else if (fson_string_length(this) == 0) then equals = .true. return end if do i=1, fson_string_length(this) if (get_char_at(this, i) /= get_char_at(other, i)) then equals = .false. return end if end do equals = .true. end function equals_string end module fson_string_m ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module fson_value_m use fson_string_m, only: fson_string implicit none private public :: fson_value, fson_value_create, fson_value_destroy, fson_value_add, fson_value_get, & fson_value_count, fson_value_print ! constants for the value types integer, public, parameter :: TYPE_UNKNOWN = -1 integer, public, parameter :: TYPE_NULL = 0 integer, public, parameter :: TYPE_OBJECT = 1 integer, public, parameter :: TYPE_ARRAY = 2 integer, public, parameter :: TYPE_STRING = 3 integer, public, parameter :: TYPE_INTEGER = 4 integer, public, parameter :: TYPE_REAL = 5 integer, public, parameter :: TYPE_LOGICAL = 6 ! ! FSON VALUE ! type fson_value type(fson_string), pointer :: name => null() integer :: value_type = TYPE_UNKNOWN logical :: value_logical integer :: value_integer real :: value_real !+PJK real(kind(1.0D0)) :: value_double !-PJK type(fson_string), pointer :: value_string => null() type(fson_value), pointer :: next => null() type(fson_value), pointer :: parent => null() type(fson_value), pointer :: children => null() end type fson_value ! ! FSON VALUE GET ! ! Use either a 1 based index or member name to get the value. interface fson_value_get module procedure get_by_index module procedure get_by_name_chars module procedure get_by_name_string end interface contains ! ! FSON VALUE CREATE ! function fson_value_create() result(new) type(fson_value), pointer :: new allocate(new) end function fson_value_create ! ! FSON VALUE DESTROY ! recursive subroutine fson_value_destroy(this) use fson_string_m, only: fson_string_destroy implicit none type(fson_value), pointer :: this if (associated(this % children)) then call fson_value_destroy(this % children) nullify(this % children) end if if (associated(this % next)) then call fson_value_destroy(this % next) nullify (this % next) end if if (associated(this % name)) then call fson_string_destroy(this % name) nullify (this % name) end if if (associated(this % value_string)) then call fson_string_destroy(this % value_string) nullify (this % value_string) end if nullify(this) end subroutine fson_value_destroy ! ! FSON VALUE ADD ! ! Adds the member to the linked list subroutine fson_value_add(this, member) type(fson_value), pointer :: this, member, p ! associate the parent member % parent => this ! add to linked list if (associated(this % children)) then ! get to the tail of the linked list p => this % children do while (associated(p % next)) p => p % next end do p % next => member else this % children => member end if end subroutine fson_value_add ! ! FSON_VALUE_COUNT ! integer function fson_value_count(this) result(count) type(fson_value), pointer :: this, p count = 0 p => this % children do while (associated(p)) count = count + 1 p => p % next end do end function fson_value_count ! ! GET BY INDEX ! function get_by_index(this, index) result(p) type(fson_value), pointer :: this, p integer, intent(in) :: index integer :: i p => this % children do i = 1, index - 1 p => p % next end do end function get_by_index ! ! GET BY NAME CHARS ! function get_by_name_chars(this, name) result(p) use fson_string_m, only: fson_string, fson_string_create implicit none type(fson_value), pointer :: this, p character(len=*), intent(in) :: name type(fson_string), pointer :: string ! convert the char array into a string string => fson_string_create(name) p => get_by_name_string(this, string) end function get_by_name_chars ! ! GET BY NAME STRING ! function get_by_name_string(this, name) result(p) use fson_string_m, only: fson_string, fson_string_equals implicit none type(fson_value), pointer :: this, p type(fson_string), pointer :: name integer :: i if (this % value_type /= TYPE_OBJECT) then nullify(p) return end if do i=1, fson_value_count(this) p => fson_value_get(this, i) if (fson_string_equals(p%name, name)) then return end if end do ! didn't find anything nullify(p) end function get_by_name_string ! ! FSON VALUE PRINT ! recursive subroutine fson_value_print(this, indent) use fson_string_m, only: fson_string_copy implicit none type(fson_value), pointer :: this, element integer, optional, intent(in) :: indent character(len=1024) :: tmp_chars integer :: tab, i, count, spaces !+PJK if (.not.associated(this)) return !-PJK if (present(indent)) then tab = indent else tab = 0 end if spaces = tab * 2 select case (this % value_type) case(TYPE_OBJECT) print *, repeat(" ", spaces), "{" count = fson_value_count(this) do i = 1, count ! get the element element => fson_value_get(this, i) ! get the name call fson_string_copy(element % name, tmp_chars) ! print the name print *, repeat(" ", spaces), '"', trim(tmp_chars), '":' ! recursive print of the element call fson_value_print(element, tab + 1) ! print the separator if required if (i < count) then print *, repeat(" ", spaces), "," end if end do print *, repeat(" ", spaces), "}" case (TYPE_ARRAY) print *, repeat(" ", spaces), "[" count = fson_value_count(this) do i = 1, count ! get the element element => fson_value_get(this, i) ! recursive print of the element call fson_value_print(element, tab + 1) ! print the separator if required if (i < count) then print *, "," end if end do print *, repeat(" ", spaces), "]" case (TYPE_NULL) print *, repeat(" ", spaces), "null" case (TYPE_STRING) call fson_string_copy(this % value_string, tmp_chars) print *, repeat(" ", spaces), '"', trim(tmp_chars), '"' case (TYPE_LOGICAL) if (this % value_logical) then print *, repeat(" ", spaces), "true" else print *, repeat(" ", spaces), "false" end if case (TYPE_INTEGER) print *, repeat(" ", spaces), this % value_integer case (TYPE_REAL) print *, repeat(" ", spaces), this % value_real ! N.B. doubles will be shown as single precision end select end subroutine fson_value_print end module fson_value_m ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Modifications by P J Knight to handle arrays more conveniently than by providing ! an array_callback argument to get_array, and to handle double precision values better module fson_path_m private public :: fson_path_get, array_callback interface fson_path_get module procedure get_by_path module procedure get_integer module procedure get_real module procedure get_double module procedure get_logical module procedure get_chars module procedure get_array !+PJK module procedure get_int_array module procedure get_real_array module procedure get_double_array module procedure get_string_array module procedure get_int_array_in_struct module procedure get_real_array_in_struct module procedure get_double_array_in_struct module procedure get_string_array_in_struct !-PJK end interface contains ! ! GET BY PATH ! ! $ = root ! @ = this ! . = child object member ! [] = child array element ! recursive subroutine get_by_path(this, path, p) use fson_value_m, only: fson_value, fson_value_get implicit none type(fson_value), pointer :: this, p character(len=*), intent(inout) :: path integer :: i, length, child_i character :: c logical :: array ! default to assuming relative to this p => this child_i = 1 array = .false. length = len_trim(path) do i=1, length c = path(i:i) select case (c) case ("$") ! root do while (associated (p % parent)) p => p % parent end do child_i = i + 1 case ("@") ! this p => this child_i = i + 1 case (".", "[") ! get child member from p if (child_i < i) then p => fson_value_get(p, path(child_i:i-1)) else child_i = i + 1 cycle end if if (.not.associated(p)) then return end if child_i = i + 1 ! check if this is an array ! if so set the array flag if (c == "[") then ! start looking for the array element index array = .true. end if case ("]") if (.not.array) then print *, "ERROR: Unexpected ], not missing preceding [" call exit(1) end if array = .false. child_i = parse_integer(path(child_i:i-1)) p => fson_value_get(p, child_i) child_i = i + 1 end select end do ! grab the last child if present in the path if (child_i <= length) then p => fson_value_get(p, path(child_i:i-1)) if (.not.associated(p)) then return else end if end if end subroutine get_by_path ! ! PARSE INTEGER ! integer function parse_integer(chars) result(integral) character(len=*) :: chars character :: c integer :: tmp, i integral = 0 do i=1, len_trim(chars) c = chars(i:i) select case(c) case ("0":"9") ! digit read (c, '(i1)') tmp ! shift if (i > 1) then integral = integral * 10 end if ! add integral = integral + tmp case default return end select end do end function parse_integer ! ! GET INTEGER ! subroutine get_integer(this, path, value) use fson_value_m, only: type_integer, type_real, type_logical, fson_value implicit none type(fson_value), pointer :: this, p character(len=*), optional :: path integer :: value nullify(p) if (present(path)) then call get_by_path(this=this, path=path, p=p) else p => this end if if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_INTEGER) then value = p % value_integer else if (p % value_type == TYPE_REAL) then value = p % value_real else if (p % value_type == TYPE_LOGICAL) then if (p % value_logical) then value = 1 else value = 0 end if else print *, "Unable to resolve value to integer: ", path call exit(1) end if end subroutine get_integer ! ! GET REAL ! subroutine get_real(this, path, value) use fson_value_m, only: type_integer, type_real, type_logical, fson_value implicit none type(fson_value), pointer :: this, p character(len=*), optional :: path real :: value nullify(p) if (present(path)) then call get_by_path(this=this, path=path, p=p) else p => this end if if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_INTEGER) then value = p % value_integer else if (p % value_type == TYPE_REAL) then value = p % value_real else if (p % value_type == TYPE_LOGICAL) then if (p % value_logical) then value = 1 else value = 0 end if else print *, "Unable to resolve value to real: ", path call exit(1) end if end subroutine get_real ! ! GET DOUBLE ! subroutine get_double(this, path, value) use fson_value_m, only: type_integer, type_real, type_logical, fson_value implicit none type(fson_value), pointer :: this, p character(len=*), optional :: path real(kind(1.0D0)) :: value nullify(p) if (present(path)) then call get_by_path(this=this, path=path, p=p) else p => this end if if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_INTEGER) then value = p % value_integer else if (p % value_type == TYPE_REAL) then value = p % value_double ! PJK from value_real else if (p % value_type == TYPE_LOGICAL) then if (p % value_logical) then value = 1 else value = 0 end if else print *, "Unable to resolve value to double: ", path call exit(1) end if end subroutine get_double ! ! GET LOGICAL ! subroutine get_logical(this, path, value) use fson_value_m, only: type_integer, type_logical, fson_value implicit none type(fson_value), pointer :: this, p character(len=*), optional :: path logical :: value nullify(p) if (present(path)) then call get_by_path(this=this, path=path, p=p) else p => this end if if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_INTEGER) then value = (p % value_integer > 0) else if (p % value_type == TYPE_LOGICAL) then value = p % value_logical else print *, "Unable to resolve value to logical: ", path call exit(1) end if end subroutine get_logical ! ! GET CHARS ! subroutine get_chars(this, path, value) use fson_value_m, only: type_string, fson_value use fson_string_m, only: fson_string_copy implicit none type(fson_value), pointer :: this, p character(len=*), optional :: path character(len=*) :: value nullify(p) if (present(path)) then call get_by_path(this=this, path=path, p=p) else p => this end if if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_STRING) then call fson_string_copy(p % value_string, value) else print *, "Unable to resolve value to characters: ", path call exit(1) end if end subroutine get_chars ! ! GET ARRAY (original version using array_callback) ! subroutine get_array(this, path, array_callback) use fson_value_m, only: type_array, fson_value_get, fson_value_count, & fson_value implicit none type(fson_value), pointer :: this, p, element character(len=*), optional :: path integer :: index, count ! ELEMENT CALLBACK (PJK: Added example comments) interface subroutine array_callback(element, index, count) use fson_value_m, only: fson_value implicit none ! In the actual routine add a second 'use' line as follows: !use shared_data ! contains declarations for the array(s) to be populated type(fson_value), pointer :: element integer :: index, count ! Example usage in the actual routine: ! call fson_get(element, "element_name", array_name(index)) end subroutine array_callback end interface nullify(p) ! resolve the path to the value if (present(path)) then call get_by_path(this=this, path=path, p=p) else p => this end if if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_ARRAY) then count = fson_value_count(p) do index = 1, count element => fson_value_get(p, index) call array_callback(element, index, count) end do else print *, "Resolved value is not an array. ", path call exit(1) end if end subroutine get_array !+PJK ! ! GET INT ARRAY ! subroutine get_int_array(this, path, array) use fson_value_m, only: type_array, fson_value_get, fson_value_count, & fson_value implicit none type(fson_value), pointer :: this, p, element character(len=*), optional :: path integer :: index, count integer, dimension(:) :: array nullify(p) ! resolve the path to the value if (present(path)) then call get_by_path(this=this, path=path, p=p) else p => this end if if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_ARRAY) then count = fson_value_count(p) do index = 1, count element => fson_value_get(p, index) array(index) = element%value_integer end do else print *, "Resolved value is not an array. ", path call exit(1) end if end subroutine get_int_array ! ! GET REAL ARRAY ! subroutine get_real_array(this, path, array) use fson_value_m, only: type_array, fson_value_get, fson_value_count, & fson_value implicit none type(fson_value), pointer :: this, p, element character(len=*), optional :: path integer :: index, count real, dimension(:) :: array nullify(p) ! resolve the path to the value if (present(path)) then call get_by_path(this=this, path=path, p=p) else p => this end if if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_ARRAY) then count = fson_value_count(p) do index = 1, count element => fson_value_get(p, index) array(index) = element%value_real end do else print *, "Resolved value is not an array. ", path call exit(1) end if end subroutine get_real_array ! ! GET DOUBLE ARRAY ! subroutine get_double_array(this, path, array) use fson_value_m, only: type_array, fson_value_get, fson_value_count, & fson_value implicit none type(fson_value), pointer :: this, p, element character(len=*), optional :: path integer :: index, count real(kind(1.0D0)), dimension(:) :: array nullify(p) ! resolve the path to the value if (present(path)) then call get_by_path(this=this, path=path, p=p) else p => this end if if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_ARRAY) then count = fson_value_count(p) do index = 1, count element => fson_value_get(p, index) array(index) = element%value_double end do else print *, "Resolved value is not an array. ", path call exit(1) end if end subroutine get_double_array ! ! GET STRING ARRAY ! subroutine get_string_array(this, path, array) use fson_value_m, only: fson_value_count, fson_value_get, fson_value, & TYPE_ARRAY use fson_string_m, only: fson_string_copy implicit none type(fson_value), pointer :: this, p, element character(len=*), optional :: path integer :: index, count character(len=*), dimension(:) :: array nullify(p) ! resolve the path to the value if (present(path)) then call get_by_path(this=this, path=path, p=p) else p => this end if if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_ARRAY) then count = fson_value_count(p) do index = 1, count element => fson_value_get(p, index) call fson_string_copy(element%value_string, array(index)) end do else print *, "Resolved value is not an array. ", path call exit(1) end if end subroutine get_string_array ! ! GET INT ARRAY IN STRUCTURE ! subroutine get_int_array_in_struct(this, path, subpath, array) use fson_value_m, only: fson_value_count, fson_value_get, fson_value, & TYPE_ARRAY implicit none type(fson_value), pointer :: this, p, element character(len=*) :: path, subpath integer, dimension(:), intent(out) :: array integer :: index, count nullify(p) ! resolve the path to the value call get_by_path(this=this, path=path, p=p) if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_ARRAY) then count = fson_value_count(p) do index = 1, count element => fson_value_get(p, index) call get_integer(element, subpath, array(index)) end do else print *, "Resolved value is not an array. ", path call exit(1) end if end subroutine get_int_array_in_struct ! ! GET REAL ARRAY IN STRUCTURE ! subroutine get_real_array_in_struct(this, path, subpath, array) use fson_value_m, only: fson_value_count, fson_value_get, fson_value, & TYPE_ARRAY implicit none type(fson_value), pointer :: this, p, element character(len=*) :: path, subpath real, dimension(:), intent(out) :: array integer :: index, count nullify(p) ! resolve the path to the value call get_by_path(this=this, path=path, p=p) if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_ARRAY) then count = fson_value_count(p) do index = 1, count element => fson_value_get(p, index) call get_real(element, subpath, array(index)) end do else print *, "Resolved value is not an array. ", path call exit(1) end if end subroutine get_real_array_in_struct ! ! GET DOUBLE ARRAY IN STRUCTURE ! subroutine get_double_array_in_struct(this, path, subpath, array) use fson_value_m, only: fson_value_count, fson_value_get, fson_value, & TYPE_ARRAY implicit none type(fson_value), pointer :: this, p, element character(len=*) :: path, subpath real(kind(1.0D0)), dimension(:), intent(out) :: array integer :: index, count nullify(p) ! resolve the path to the value call get_by_path(this=this, path=path, p=p) if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_ARRAY) then count = fson_value_count(p) do index = 1, count element => fson_value_get(p, index) call get_double(element, subpath, array(index)) end do else print *, "Resolved value is not an array. ", path call exit(1) end if end subroutine get_double_array_in_struct ! ! GET STRING ARRAY IN STRUCTURE ! subroutine get_string_array_in_struct(this, path, subpath, array) use fson_value_m, only: fson_value_count, fson_value_get, fson_value, & TYPE_ARRAY implicit none type(fson_value), pointer :: this, p, element character(len=*) :: path, subpath character(len=*), dimension(:), intent(out) :: array integer :: index, count nullify(p) ! resolve the path to the value call get_by_path(this=this, path=path, p=p) if (.not.associated(p)) then print *, "Unable to resolve path: ", path call exit(1) end if if (p % value_type == TYPE_ARRAY) then count = fson_value_count(p) do index = 1, count element => fson_value_get(p, index) call get_chars(element, subpath, array(index)) end do else print *, "Resolved value is not an array. ", path call exit(1) end if end subroutine get_string_array_in_struct !-PJK end module fson_path_m ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module fson_library !! JSON file reading module !! author: P J Knight, CCFE, Culham Science Centre !! N/A !! This module uses a local copy of the freely-available FSON library, !! written by Joseph A. Levin and distributed via github, !! to enable PROCESS to read in information from JSON-formatted files. !! None ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use fson_value_m, only: fson_print => fson_value_print, & fson_destroy => fson_value_destroy, fson_value use fson_path_m, only: fson_get => fson_path_get implicit none private public :: fson_parse, fson_value, fson_get, fson_print, fson_destroy, & init_fson_library ! FILE IOSTAT CODES integer, parameter :: end_of_file = -1 integer, parameter :: end_of_record = -2 ! PARSING STATES integer, parameter :: STATE_LOOKING_FOR_VALUE = 1 integer, parameter :: STATE_IN_OBJECT = 2 integer, parameter :: STATE_IN_PAIR_NAME = 3 integer, parameter :: STATE_IN_PAIR_VALUE = 4 ! POP/PUSH CHARACTER integer :: pushed_index character (len = 10) :: pushed_char contains subroutine init_fson_library !! Initialise fson library module variables implicit none pushed_index = 0 end subroutine init_fson_library ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! FSON PARSE ! function fson_parse(file, unit) result(p) use fson_value_m, only: fson_value_create implicit none type(fson_value), pointer :: p integer, optional, intent(inout) :: unit character(len = *), intent(in) :: file logical :: unit_available integer :: u ! init the pointer to null nullify(p) ! select the file unit to use if (present(unit)) then u = unit else ! find the first available unit unit_available = .false. u = 20 do while (.not.unit_available) inquire(unit=u, exist=unit_available) u = u + 1 end do end if ! open the file open (unit=u, file=file, status="old", action="read", & form="formatted", position="rewind") ! create the value and associate the pointer p => fson_value_create() ! parse as a value call parse_value(unit=u, value=p) ! close the file if ( .not. present(unit)) then close (u) end if end function fson_parse ! ! PARSE_VALUE ! recursive subroutine parse_value(unit, value) use fson_value_m, only: TYPE_ARRAY, TYPE_LOGICAL, TYPE_NULL, TYPE_OBJECT, & TYPE_STRING implicit none integer, intent(inout) :: unit type(fson_value), pointer :: value logical :: eof character :: c ! for some unknown reason the next pointer is getting messed with the pop type(fson_value), pointer :: hack ! start the hack hack => value % next ! pop the next non whitespace character off the file c = pop_char(unit, eof=eof, skip_ws=.true.) ! finish the hack; set the next pointer to whatever it was before the pop value % next => hack if (eof) then return else select case (c) case ("{") ! start object value % value_type = TYPE_OBJECT call parse_object(unit, value) case ("[") ! start array value % value_type = TYPE_ARRAY call parse_array(unit, value) case ("]") ! end an empty array nullify(value) case ('"') ! string value % value_type = TYPE_STRING value % value_string => parse_string(unit) case ("t") ! true value % value_type = TYPE_LOGICAL call parse_for_chars(unit, "rue") value % value_logical = .true. case ("f") ! false value % value_type = TYPE_LOGICAL value % value_logical = .false. call parse_for_chars(unit, "alse") case ("n") value % value_type = TYPE_NULL call parse_for_chars(unit, "ull") case("-", "0": "9") call push_char(c) call parse_number(unit, value) case default print *, "ERROR: Unexpected character while parsing value. '", c, "' ASCII=", iachar(c) call exit (1) end select end if end subroutine parse_value ! ! PARSE OBJECT ! recursive subroutine parse_object(unit, parent) use fson_value_m, only: fson_value_create, fson_value_add implicit none integer, intent(inout) :: unit type(fson_value), pointer :: parent, pair logical :: eof character :: c ! pair name c = pop_char(unit, eof=eof, skip_ws=.true.) if (eof) then print *, "ERROR: Unexpected end of file while parsing start of object." call exit (1) else if ("}" == c) then ! end of an empty object return else if ('"' == c) then pair => fson_value_create() pair % name => parse_string(unit) else print *, "ERROR: Expecting string: '", c, "'" call exit (1) end if ! pair value c = pop_char(unit, eof=eof, skip_ws=.true.) if (eof) then print *, "ERROR: Unexpected end of file while parsing object member. 1" call exit (1) else if (":" == c) then ! parse the value call parse_value(unit, pair) call fson_value_add(parent, pair) else print *, "ERROR: Expecting : and then a value. ", c call exit (1) end if ! another possible pair c = pop_char(unit, eof=eof, skip_ws=.true.) if (eof) then return else if ("," == c) then ! read the next member call parse_object(unit=unit, parent=parent) else if ("}" == c) then return else print *, "ERROR: Expecting end of object.", c call exit (1) end if end subroutine parse_object ! ! PARSE ARRAY ! recursive subroutine parse_array(unit, array) use fson_value_m, only: fson_value_create, fson_value_add implicit none integer, intent(inout) :: unit type(fson_value), pointer :: array, element logical :: eof character :: c ! try to parse an element value element => fson_value_create() call parse_value(unit, element) ! parse value will disassociate an empty array value if (associated(element)) then call fson_value_add(array, element) end if ! popped the next character c = pop_char(unit, eof=eof, skip_ws=.true.) if (eof) then return else if ("," == c) then ! parse the next element call parse_array(unit, array) else if ("]" == c) then ! end of array return end if end subroutine parse_array ! ! PARSE STRING ! function parse_string(unit) result(string) use fson_string_m, only: fson_string, fson_string_create, fson_string_append implicit none integer, intent(inout) :: unit type(fson_string), pointer :: string logical :: eof character :: c, last string => fson_string_create() do c = pop_char(unit, eof=eof, skip_ws=.false.) if (eof) then print *, "Expecting end of string" call exit(1)! else if ('"' == c .and. last /= '\') then !' exit else last = c call fson_string_append(string, c) end if end do end function parse_string ! ! PARSE FOR CHARACTERS ! subroutine parse_for_chars(unit, chars) integer, intent(in) :: unit character(len = *), intent(in) :: chars integer :: i, length logical :: eof character :: c length = len_trim(chars) do i = 1, length c = pop_char(unit, eof=eof, skip_ws=.true.) if (eof) then print *, "ERROR: Unexpected end of file while parsing array." call exit (1) else if (c /= chars(i:i)) then print *, "ERROR: Unexpected character.'", c,"'", chars(i:i) call exit (1) end if end do end subroutine parse_for_chars ! ! PARSE NUMBER ! subroutine parse_number(unit, value) use fson_value_m, only: TYPE_INTEGER, TYPE_REAL implicit none integer, intent(inout) :: unit type(fson_value), pointer :: value logical :: eof, negative, decimal, scientific character :: c integer :: integral, exp, digit_count real(kind(1.0D0)) :: frac ! first character is either - or a digit c = pop_char(unit, eof=eof, skip_ws=.true.) if (eof) then print *, "ERROR: Unexpected end of file while parsing number." call exit (1) else if ("-" == c) then negative = .true. else negative = .false. call push_char(c) end if ! parse the integral integral = parse_integer(unit) decimal = .false. scientific = .false. do ! first character is either - or a digit c = pop_char(unit, eof=eof, skip_ws=.true.) if (eof) then print *, "ERROR: Unexpected end of file while parsing number." call exit (1) else select case (c) case (".") ! this is already fractional number if (decimal) then ! already found a decimal place print *, "ERROR: Unexpected second decimal place while parsing number." call exit(1) end if decimal = .true. frac = parse_integer(unit, digit_count) frac = frac / (10.0D0 ** digit_count) case ("e", "E") ! this is already an exponent number if (scientific) then ! already found a e place print *, "ERROR: Unexpected second exponent while parsing number." call exit(1) end if scientific = .true. ! this number has an exponent exp = parse_integer(unit) case default ! this is a integer if (decimal) then ! add the integral frac = frac + integral if (scientific) then ! apply exponent frac = frac * (10.0D0 ** exp) end if ! apply negative if (negative) then frac = frac * (-1) end if value % value_type = TYPE_REAL value % value_real = frac value % value_double = frac else if (scientific) then ! apply exponent integral = integral * (10.0D0 ** exp) end if ! apply negative if (negative) then integral = integral * (-1) end if value % value_type = TYPE_INTEGER value % value_integer = integral !+PJK ! Following two lines are included in case the decimal point of ! a floating point number has been (accidentally) left out value % value_real = integral value % value_double = integral !-PJK end if call push_char(c) exit end select end if end do end subroutine parse_number ! ! PARSE INTEGER ! integer(kind=8) function parse_integer(unit, digit_count) result(integral) integer, intent(in) :: unit integer, optional, intent(inout) :: digit_count logical :: eof, found_sign, found_digit character :: c integer :: tmp, icount, isign integer, parameter :: max_integer_length = 18 icount = 0 integral = 0 isign = 1 found_sign = .false. found_digit = .false. do c = pop_char(unit, eof=eof, skip_ws=.true.) if (eof) then print *, "ERROR: Unexpected end of file while parsing digit." call exit (1) else select case(c) case ("+") if (found_sign.or.found_digit) then print *, "ERROR: Miss formatted number." call exit(1) end if found_sign = .true. case ("-") if (found_sign.or.found_digit) then print *, "ERROR: Miss formatted number." call exit(1) end if found_sign = .true. isign = -1 case ("0":"9") found_sign = .true. if (icount > max_integer_length) then print *, "ERROR: Too many digits for an integer." call exit(1) end if ! digit read (c, '(i1)') tmp ! shift if (icount > 0) then integral = integral * 10 end if ! add integral = integral + tmp ! increase the icount icount = icount + 1 case default if (present(digit_count)) then digit_count = icount end if call push_char(c) integral = isign * integral return end select end if end do end function parse_integer ! ! POP CHAR ! recursive character function pop_char(unit, eof, skip_ws) result(popped) integer, intent(in) :: unit logical, intent(out) :: eof logical, intent(in), optional :: skip_ws integer :: ios character :: c logical :: ignore !+PJK ios = 0 !-PJK eof = .false. if (.not.present(skip_ws)) then ignore = .false. else ignore = skip_ws end if do if (pushed_index > 0) then ! there is a character pushed back on, most likely from the number parsing c = pushed_char(pushed_index:pushed_index) pushed_index = pushed_index - 1 else read (unit=unit, fmt="(a)", advance="no", iostat=ios) c end if if (ios == end_of_record) then cycle else if (ios == end_of_file) then eof = .true. exit else if (iachar(c) <= 31) then ! PJK from 32 ! non printing ascii characters cycle else if (ignore .and. c == " ") then cycle else popped = c exit end if end do end function pop_char ! ! PUSH CHAR ! subroutine push_char(c) character, intent(inout) :: c pushed_index = pushed_index + 1 pushed_char(pushed_index:pushed_index) = c end subroutine push_char end module fson_library