diff --git a/json-fortran.fobis b/json-fortran.fobis index 019e74fda..7110cd4ca 100644 --- a/json-fortran.fobis +++ b/json-fortran.fobis @@ -149,6 +149,8 @@ rule_1 = (cd bin GLOBIGNORE='*.*' ls jf_test_* | sed 's/^\([^0-9]*\)\([0-9]*\)/\1 \2/' | sort -k2,2n | tr -d ' ' | while read TEST; do + echo "" + echo "======================================================" echo "" echo "Running ${TEST}" "./${TEST}" diff --git a/src/json_value_module.F90 b/src/json_value_module.F90 index b43555249..3b576feca 100644 --- a/src/json_value_module.F90 +++ b/src/json_value_module.F90 @@ -68,6 +68,49 @@ module json_value_module #endif !********************************************************* + type,abstract :: json_data + !! to hold the various types of JSON data + private + end type json_data + + type,extends(json_data),abstract :: json_data_with_children + !! a json data type that can have children + !! (an object or array) + integer(IK) :: n_children = 0 !! number of children + end type json_data_with_children + + type,extends(json_data) :: json_real_type + !! a `json_real` variable + real(RK) :: value = 0.0_RK + end type json_real_type + + type,extends(json_data) :: json_logical_type + !! a `json_logical` variable + logical(LK) :: value = .false. + end type json_logical_type + + type,extends(json_data) :: json_string_type + !! a `json_string` variable + character(kind=CK,len=:),allocatable :: value + end type json_string_type + + type,extends(json_data) :: json_integer_type + !! a `json_integer` variable + integer(IK) :: value = 0.0_IK + end type json_integer_type + + type,extends(json_data) :: json_null_type + !! a `json_null` variable + end type json_null_type + + type,extends(json_data_with_children) :: json_object_type + !! a `json_object` variable + end type json_object_type + + type,extends(json_data_with_children) :: json_array_type + !! a `json_array` variable + end type json_array_type + !********************************************************* !> ! Type used to construct the linked-list JSON structure. @@ -103,14 +146,8 @@ module json_value_module ! !@warning Pointers of this type should only be allocated ! using the methods from [[json_core(type)]]. - type,public :: json_value - !force the constituents to be stored contiguously - ![note: on Intel, the order of the variables below - ! is significant to avoid the misaligned field warnings] - sequence - private !for the linked list: @@ -122,15 +159,9 @@ module json_value_module character(kind=CK,len=:),allocatable :: name !! variable name (unescaped) - real(RK),allocatable :: dbl_value !! real data for this variable - logical(LK),allocatable :: log_value !! logical data for this variable - character(kind=CK,len=:),allocatable :: str_value !! string data for this variable - !! (unescaped) - integer(IK),allocatable :: int_value !! integer data for this variable - - integer(IK) :: var_type = json_unknown !! variable type - - integer(IK),private :: n_children = 0 !! number of children + class(json_data),allocatable :: data !! the JSON data. + !! when not allocated, + !! it is `json_unknown` end type json_value !********************************************************* @@ -874,6 +905,7 @@ module json_value_module !! children for duplicate keys !other private routines: + procedure,nopass :: destroy_json_data procedure :: name_equal procedure :: name_strings_equal procedure :: json_value_print @@ -1341,15 +1373,8 @@ recursive subroutine json_value_clone_func(from,to,parent,previous,next,children allocate(to) !copy over the data variables: - ! [note: the allocate() statements don't work here for the - ! deferred-length characters in gfortran-4.9] - if (allocated(from%name)) to%name = from%name - if (allocated(from%dbl_value)) allocate(to%dbl_value,source=from%dbl_value) - if (allocated(from%log_value)) allocate(to%log_value,source=from%log_value) - if (allocated(from%str_value)) to%str_value = from%str_value - if (allocated(from%int_value)) allocate(to%int_value,source=from%int_value) - to%var_type = from%var_type - to%n_children = from%n_children + if (allocated(from%name)) to%name = from%name + allocate(to%data, source=from%data) !allocate and associate the pointers as necessary: @@ -1390,18 +1415,13 @@ end subroutine json_value_clone_func ! ! Destroy the data within a [[json_value]], and reset type to `json_unknown`. - pure subroutine destroy_json_data(d) + pure subroutine destroy_json_data(p) implicit none - type(json_value),intent(inout) :: d + type(json_value),intent(inout) :: p - d%var_type = json_unknown - - if (allocated(d%log_value)) deallocate(d%log_value) - if (allocated(d%int_value)) deallocate(d%int_value) - if (allocated(d%dbl_value)) deallocate(d%dbl_value) - if (allocated(d%str_value)) deallocate(d%str_value) + if (allocated(p%data)) deallocate(p%data) end subroutine destroy_json_data !***************************************************************************************** @@ -1424,7 +1444,25 @@ subroutine json_info(json,p,var_type,n_children,name) if (.not. json%exception_thrown .and. associated(p)) then - if (present(var_type)) var_type = p%var_type + if (present(var_type)) then + if (allocated(p%data)) then + associate (data => p%data) + select type (data) + class is (json_string_type); var_type = json_string + class is (json_real_type); var_type = json_real + class is (json_integer_type); var_type = json_integer + class is (json_logical_type); var_type = json_logical + class is (json_array_type); var_type = json_array + class is (json_object_type); var_type = json_object + class is (json_null_type); var_type = json_null + class default; var_type = json_unknown + end select + end associate + else + var_type = json_unknown + end if + end if + if (present(n_children)) n_children = json%count(p) if (present(name)) then if (allocated(p%name)) then @@ -1481,7 +1519,6 @@ subroutine json_string_info(json,p,ilen,max_str_len,found) logical(LK) :: initialized !! if the output array has been sized logical(LK) :: get_max_len !! if we are returning the `max_str_len` logical(LK) :: get_ilen !! if we are returning the `ilen` array - integer(IK) :: var_type !! variable type get_max_len = present(max_str_len) get_ilen = present(ilen) @@ -1493,41 +1530,49 @@ subroutine json_string_info(json,p,ilen,max_str_len,found) if (get_max_len) max_str_len = 0 - select case (p%var_type) + if (allocated(p%data)) then + associate (data => p%data) - case (json_array) ! it's an array + select type (data) - ! call routine for each element - call json%get(p, array_callback=get_string_lengths) + class is (json_array_type) ! it's an array - case default ! not an array + ! call routine for each element + call json%get(p, array_callback=get_string_lengths) - if (json%strict_type_checking) then - ! only allowing strings to be returned - ! as strings, so we can check size directly - call json%info(p,var_type=var_type) - if (var_type==json_string) then - if (allocated(p%str_value) .and. get_max_len) & - max_str_len = len(p%str_value) - else - ! it isn't a string, so there is no length - call json%throw_exception('Error in json_string_info: '//& - 'When strict_type_checking is true '//& - 'the variable must be a character string.',& - found) - end if - else - ! in this case, we have to get the value - ! as a string to know what size it is. - call json%get(p, value=cval) - if (.not. json%exception_thrown) then - if (allocated(cval) .and. get_max_len) & - max_str_len = len(cval) - end if - end if + class default ! not an array - end select + if (json%strict_type_checking) then + ! only allowing strings to be returned + ! as strings, so we can check size directly + select type (data) + class is (json_string_type) + if (allocated(data%value) .and. get_max_len) & + max_str_len = len(data%value) + class default + ! it isn't a string, so there is no length + call json%throw_exception('Error in json_string_info: '//& + 'When strict_type_checking is true '//& + 'the variable must be a character string.',& + found) + end select + else + ! in this case, we have to get the value + ! as a string to know what size it is. + call json%get(p, value=cval) + if (.not. json%exception_thrown) then + if (allocated(cval) .and. get_max_len) & + max_str_len = len(cval) + end if + end if + end select + + end associate + else + call json%throw_exception('Error in json_string_info: '//& + 'JSON data not allocated.') + end if end if if (json%exception_thrown) then @@ -1550,12 +1595,11 @@ subroutine get_string_lengths(json, element, i, count) implicit none class(json_core),intent(inout) :: json - type(json_value),pointer,intent(in) :: element + type(json_value),pointer,intent(in) :: element !! array element integer(IK),intent(in) :: i !! index integer(IK),intent(in) :: count !! size of array character(kind=CK,len=:),allocatable :: cval - integer(IK) :: var_type if (json%exception_thrown) return @@ -1567,23 +1611,30 @@ subroutine get_string_lengths(json, element, i, count) if (json%strict_type_checking) then ! only allowing strings to be returned ! as strings, so we can check size directly - call json%info(element,var_type=var_type) - if (var_type==json_string) then - if (allocated(element%str_value)) then - if (get_max_len) then - if (len(element%str_value)>max_str_len) & - max_str_len = len(element%str_value) - end if - if (get_ilen) ilen(i) = len(element%str_value) - else - if (get_ilen) ilen(i) = 0 - end if + if (allocated(element%data)) then + associate (data => element%data) + select type (data) + class is (json_string_type) + if (allocated(data%value)) then + if (get_max_len) then + if (len(data%value)>max_str_len) & + max_str_len = len(data%value) + end if + if (get_ilen) ilen(i) = len(data%value) + else + if (get_ilen) ilen(i) = 0 + end if + class default + ! it isn't a string, so there is no length + call json%throw_exception('Error in json_string_info: '//& + 'When strict_type_checking is true '//& + 'the array must contain only '//& + 'character strings.',found) + end select + end associate else - ! it isn't a string, so there is no length call json%throw_exception('Error in json_string_info: '//& - 'When strict_type_checking is true '//& - 'the array must contain only '//& - 'character strings.',found) + 'JSON data not allocated.',found) end if else ! in this case, we have to get the value @@ -2264,41 +2315,47 @@ pure recursive subroutine json_value_destroy(json,p,destroy_next) if (allocated(p%name)) deallocate(p%name) - call destroy_json_data(p) - if (associated(p%next)) then ! check for circular references: if (associated(p, p%next)) nullify(p%next) end if - if (associated(p%children)) then - do while (p%n_children > 0) - child => p%children - if (associated(child)) then - p%children => p%children%next - p%n_children = p%n_children - 1 - ! check children for circular references: - circular = (associated(p%children) .and. & - associated(p%children,child)) - call json%destroy(child,destroy_next=.false.) - if (circular) exit - else - ! it is a malformed JSON object. But, we will - ! press ahead with the destroy process, since - ! otherwise, there would be no way to destroy it. - exit - end if - end do - nullify(p%children) - nullify(child) + if (allocated(p%data)) then + associate (data => p%data) + select type (data) + class is (json_data_with_children) + if (associated(p%children)) then + do while (data%n_children > 0) + child => p%children + if (associated(child)) then + p%children => p%children%next + data%n_children = data%n_children - 1 + ! check children for circular references: + circular = (associated(p%children) .and. & + associated(p%children,child)) + call json%destroy(child,destroy_next=.false.) + if (circular) exit + else + ! it is a malformed JSON object. But, we will + ! press ahead with the destroy process, since + ! otherwise, there would be no way to destroy it. + exit + end if + end do + nullify(p%children) + nullify(child) + end if + end select + end associate end if - if (associated(p%next) .and. des_next) call json%destroy(p%next) nullify(p%previous) nullify(p%parent) nullify(p%tail) + call json%destroy_json_data(p) + if (associated(p)) deallocate(p) nullify(p) @@ -2403,7 +2460,12 @@ subroutine json_value_remove(json,p,destroy) end if - parent%n_children = parent%n_children - 1 + associate (parent_data => parent%data) + select type (parent_data) + class is (json_data_with_children) + parent_data%n_children = parent_data%n_children - 1 + end select + end associate end if @@ -2801,65 +2863,11 @@ recursive subroutine check_if_valid(p,require_parent) if (is_valid .and. associated(p)) then - ! data type: - select case (p%var_type) - case(json_null,json_object,json_array) - if (allocated(p%log_value) .or. allocated(p%int_value) .or. & - allocated(p%dbl_value) .or. allocated(p%str_value)) then - error_msg = 'incorrect data allocated for '//& - 'json_null, json_object, or json_array variable type' - is_valid = .false. - return - end if - case(json_logical) - if (.not. allocated(p%log_value)) then - error_msg = 'log_value should be allocated for json_logical variable type' - is_valid = .false. - return - else if (allocated(p%int_value) .or. & - allocated(p%dbl_value) .or. allocated(p%str_value)) then - error_msg = 'incorrect data allocated for json_logical variable type' - is_valid = .false. - return - end if - case(json_integer) - if (.not. allocated(p%int_value)) then - error_msg = 'int_value should be allocated for json_integer variable type' - is_valid = .false. - return - else if (allocated(p%log_value) .or. & - allocated(p%dbl_value) .or. allocated(p%str_value)) then - error_msg = 'incorrect data allocated for json_integer variable type' - is_valid = .false. - return - end if - case(json_real) - if (.not. allocated(p%dbl_value)) then - error_msg = 'dbl_value should be allocated for json_real variable type' - is_valid = .false. - return - else if (allocated(p%log_value) .or. allocated(p%int_value) .or. & - allocated(p%str_value)) then - error_msg = 'incorrect data allocated for json_real variable type' - is_valid = .false. - return - end if - case(json_string) - if (.not. allocated(p%str_value)) then - error_msg = 'str_value should be allocated for json_string variable type' - is_valid = .false. - return - else if (allocated(p%log_value) .or. allocated(p%int_value) .or. & - allocated(p%dbl_value)) then - error_msg = 'incorrect data allocated for json_string variable type' - is_valid = .false. - return - end if - case default + if (.not. allocated(p%data)) then error_msg = 'invalid JSON variable type' is_valid = .false. return - end select + end if if (require_parent .and. .not. associated(p%parent)) then error_msg = 'parent pointer is not associated' @@ -2869,12 +2877,17 @@ recursive subroutine check_if_valid(p,require_parent) if (.not. allocated(p%name)) then if (associated(p%parent)) then - if (p%parent%var_type/=json_array) then - error_msg = 'JSON variable must have a name if not an '//& - 'array element or the root' - is_valid = .false. - return - end if + associate (data => p%parent%data) + select type (data) + class is (json_array_type) + ! array: OK not to have a name + class default + error_msg = 'JSON variable must have a name if not an '//& + 'array element or the root' + is_valid = .false. + return + end select + end associate end if end if @@ -2899,60 +2912,73 @@ recursive subroutine check_if_valid(p,require_parent) if (associated(p%children)) then - if (p%var_type/=json_array .and. p%var_type/=json_object) then - error_msg = 'only arrays and objects can have children' - is_valid = .false. - return - end if + if (allocated(p%data)) then + associate (data => p%data) - ! first validate children pointers: + select type (data) + class is (json_data_with_children) + ! first validate children pointers: - previous => null() - element => p%children - do i = 1_IK, p%n_children - if (.not. associated(element%parent,p)) then - error_msg = 'child''s parent pointer not properly associated' - is_valid = .false. - return - end if - if (i==1 .and. associated(element%previous)) then - error_msg = 'first child shouldn''t have a previous' - is_valid = .false. - return - end if - if (i1) then - if (.not. associated(previous,element%previous)) then - error_msg = 'previous pointer not properly associated' + previous => null() + element => p%children + do i = 1_IK, data%n_children + if (.not. associated(element%parent,p)) then + error_msg = 'child''s parent pointer not properly associated' + is_valid = .false. + return + end if + if (i==1 .and. associated(element%previous)) then + error_msg = 'first child shouldn''t have a previous' + is_valid = .false. + return + end if + if (i1) then + if (.not. associated(previous,element%previous)) then + error_msg = 'previous pointer not properly associated' + is_valid = .false. + return + end if + end if + if (i==data%n_children .and. & + .not. associated(element%parent%tail,element)) then + error_msg = 'parent''s tail pointer not properly associated' + is_valid = .false. + return + end if + if (i element + element => element%next + end if + end do + + !now check all the children: + call check_if_valid(p%children,require_parent=.true.) + + class default + + error_msg = 'only arrays and objects can have children' is_valid = .false. return - end if - end if - if (i==p%n_children .and. & - .not. associated(element%parent%tail,element)) then - error_msg = 'parent''s tail pointer not properly associated' - is_valid = .false. - return - end if - if (i element - element => element%next - end if - end do - !now check all the children: - call check_if_valid(p%children,require_parent=.true.) + end select + end associate + else + error_msg = 'JSON data not allocated' + is_valid = .false. + return + end if end if end if @@ -3403,38 +3429,42 @@ subroutine json_value_add_member(json,p,member) type(json_value),pointer :: member !! the child member !! to add to `p` - integer(IK) :: var_type !! variable type of `p` - if (.not. json%exception_thrown) then if (associated(p)) then - call json%info(p,var_type=var_type) + if (allocated(p%data)) then + associate (data => p%data) - select case (var_type) - case(json_object, json_array) + select type (data) + class is (json_data_with_children) - ! associate the parent - member%parent => p + ! associate the parent + member%parent => p - ! add to linked list - if (associated(p%children)) then - p%tail%next => member - member%previous => p%tail - else - p%children => member - member%previous => null() !first in the list - end if + ! add to linked list + if (associated(p%children)) then + p%tail%next => member + member%previous => p%tail + else + p%children => member + member%previous => null() !first in the list + end if - ! new member is now the last one in the list - p%tail => member - p%n_children = p%n_children + 1 + ! new member is now the last one in the list + p%tail => member + data%n_children = data%n_children + 1 - case default - call json%throw_exception('Error in json_value_add_member: '//& - 'can only add child to object or array') - end select + class default + call json%throw_exception('Error in json_value_add_member: '//& + 'can only add child to object or array') + end select + end associate + else + call json%throw_exception('Error in json_value_add_member: '//& + 'JSON data not allocated') + end if else call json%throw_exception('Error in json_value_add_member: '//& 'the pointer is not associated') @@ -3525,8 +3555,13 @@ subroutine json_value_insert_after(json,p,element) end do if (associated(parent)) then - ! update parent's child counter: - parent%n_children = parent%n_children + n + associate (data => parent%data) + select type (data) + class is (json_data_with_children) + ! update parent's child counter: + data%n_children = data%n_children + n + end select + end associate ! if p is last of parents children then ! also have to update parent tail pointer: if (associated(parent%tail,p)) then @@ -3538,8 +3573,12 @@ subroutine json_value_insert_after(json,p,element) ! element is apparently part of an existing list, ! so have to update that as well. if (associated(element%previous%parent)) then - element%previous%parent%n_children = & - element%previous%parent%n_children - n + associate (data => element%previous%parent%data) + select type (data) + class is (json_data_with_children) + data%n_children = data%n_children - n + end select + end associate element%previous%parent%tail => & element%previous ! now the last one in the list else @@ -3734,13 +3773,17 @@ subroutine json_add_integer_by_path(json,me,path,value,found,was_created) ! being changed (for example, if an array ! is being replaced with a scalar). - if (p%var_type==json_integer) then - p%int_value = value - else - call json%info(p,name=name) - call json%create_integer(tmp,value,name) - call json%replace(p,tmp,destroy=.true.) - end if + if (.not. allocated(p%data)) allocate(json_integer_type :: p%data) + associate (data => p%data) + select type (data) + class is (json_integer_type) + data%value = value + class default + call json%info(p,name=name) + call json%create_integer(tmp,value,name) + call json%replace(p,tmp,destroy=.true.) + end select + end associate end if @@ -3821,13 +3864,17 @@ subroutine json_add_real_by_path(json,me,path,value,found,was_created) ! being changed (for example, if an array ! is being replaced with a scalar). - if (p%var_type==json_real) then - p%dbl_value = value - else - call json%info(p,name=name) - call json%create_real(tmp,value,name) - call json%replace(p,tmp,destroy=.true.) - end if + if (.not. allocated(p%data)) allocate(json_real_type :: p%data) + associate (data => p%data) + select type (data) + class is (json_real_type) + data%value = value + class default + call json%info(p,name=name) + call json%create_real(tmp,value,name) + call json%replace(p,tmp,destroy=.true.) + end select + end associate end if @@ -3992,13 +4039,17 @@ subroutine json_add_logical_by_path(json,me,path,value,found,was_created) ! being changed (for example, if an array ! is being replaced with a scalar). - if (p%var_type==json_logical) then - p%log_value = value - else - call json%info(p,name=name) - call json%create_logical(tmp,value,name) - call json%replace(p,tmp,destroy=.true.) - end if + if (.not. allocated(p%data)) allocate(json_logical_type :: p%data) + associate (data => p%data) + select type (data) + class is (json_logical_type) + data%value = value + class default + call json%info(p,name=name) + call json%create_logical(tmp,value,name) + call json%replace(p,tmp,destroy=.true.) + end select + end associate end if @@ -4082,13 +4133,17 @@ subroutine json_add_string_by_path(json,me,path,value,found,& ! being changed (for example, if an array ! is being replaced with a scalar). - if (p%var_type==json_string) then - p%str_value = value - else - call json%info(p,name=name) - call json%create_string(tmp,value,name,trim_str,adjustl_str) - call json%replace(p,tmp,destroy=.true.) - end if + if (.not. allocated(p%data)) allocate(json_string_type :: p%data) + associate (data => p%data) + select type (data) + class is (json_string_type) + data%value = value + class default + call json%info(p,name=name) + call json%create_string(tmp,value,name,trim_str,adjustl_str) + call json%replace(p,tmp,destroy=.true.) + end select + end associate end if @@ -5320,8 +5375,20 @@ function json_count(json,p) result(count) integer(IK) :: count !! number of children in `p`. if (associated(p)) then - count = p%n_children + if (allocated(p%data)) then + associate (data => p%data) + select type (data) + class is (json_data_with_children) + count = data%n_children + class default + count = 0_IK + end select + end associate + else + count = 0_IK + end if else + count = 0_IK call json%throw_exception('Error in json_count: '//& 'pointer is not associated.') end if @@ -5461,76 +5528,93 @@ subroutine json_value_get_child_by_index(json, p, idx, child, found) if (.not. json%exception_thrown) then - if (associated(p%children)) then + if (allocated(p%data)) then + associate (data => p%data) - ! If getting first or last child, we can do this quickly. - ! Otherwise, traverse the list. - if (idx==1) then + select type (data) + class is (json_data_with_children) - child => p%children ! first one + if (associated(p%children)) then - elseif (idx==p%n_children) then + ! If getting first or last child, we can do this quickly. + ! Otherwise, traverse the list. + if (idx==1) then - if (associated(p%tail)) then - child => p%tail ! last one - else - call json%throw_exception('Error in json_value_get_child_by_index:'//& - ' child%tail is not associated.',found) - end if + child => p%children ! first one - elseif (idx<1 .or. idx>p%n_children) then + elseif (idx==data%n_children) then - call json%throw_exception('Error in json_value_get_child_by_index:'//& - ' idx is out of range.',found) + if (associated(p%tail)) then + child => p%tail ! last one + else + call json%throw_exception('Error in json_value_get_child_by_index:'//& + ' child%tail is not associated.',found) + end if - else + elseif (idx<1 .or. idx>data%n_children) then - ! if idx is closer to the end, we traverse the list backward from tail, - ! otherwise we traverse it forward from children: + call json%throw_exception('Error in json_value_get_child_by_index:'//& + ' idx is out of range.',found) - if (p%n_children-idx < idx) then ! traverse backward + else - child => p%tail + ! if idx is closer to the end, we traverse the list backward from tail, + ! otherwise we traverse it forward from children: - do i = 1, p%n_children - idx + if (data%n_children-idx < idx) then ! traverse backward - if (associated(child%previous)) then - child => child%previous - else - call json%throw_exception('Error in json_value_get_child_by_index:'//& - ' child%previous is not associated.',found) - nullify(child) - exit - end if + child => p%tail - end do + do i = 1, data%n_children - idx - else ! traverse forward + if (associated(child%previous)) then + child => child%previous + else + call json%throw_exception('Error in json_value_get_child_by_index:'//& + ' child%previous is not associated.',found) + nullify(child) + exit + end if - child => p%children + end do - do i = 1, idx - 1 + else ! traverse forward + + child => p%children + + do i = 1, idx - 1 + + if (associated(child%next)) then + child => child%next + else + call json%throw_exception('Error in json_value_get_child_by_index:'//& + ' child%next is not associated.',found) + nullify(child) + exit + end if + + end do + + end if - if (associated(child%next)) then - child => child%next - else - call json%throw_exception('Error in json_value_get_child_by_index:'//& - ' child%next is not associated.',found) - nullify(child) - exit end if - end do + else - end if + call json%throw_exception('Error in json_value_get_child_by_index:'//& + ' p%children is not associated.',found) - end if + end if - else + class default + call json%throw_exception('Error in json_value_get_child_by_index:'//& + ' only objects and arrays can have children.',found) + end select + end associate + else call json%throw_exception('Error in json_value_get_child_by_index:'//& - ' p%children is not associated.',found) - + ' JSON data not allocated.',found) end if ! found output: @@ -5598,8 +5682,9 @@ subroutine json_value_get_child_by_name(json, p, name, child, found) !! found, no exception will be !! thrown). - integer(IK) :: i,n_children - logical :: error + integer(IK) :: i !! counter + integer(IK) :: n_children !! number of children in `p` + logical :: error !! will be false if `name` is found nullify(child) @@ -5608,25 +5693,30 @@ subroutine json_value_get_child_by_name(json, p, name, child, found) if (associated(p)) then error = .true. ! will be false if it is found - if (p%var_type==json_object) then - n_children = json%count(p) - child => p%children !start with first one - do i=1, n_children - if (.not. associated(child)) then - call json%throw_exception(& - 'Error in json_value_get_child_by_name: '//& - 'Malformed JSON linked list',found) - exit - end if - if (allocated(child%name)) then - !name string matching routine: - if (json%name_equal(child,name)) then - error = .false. - exit - end if - end if - child => child%next - end do + if (allocated(p%data)) then + associate (data => p%data) + select type (data) + class is (json_object_type) + n_children = json%count(p) + child => p%children !start with first one + do i=1, n_children + if (.not. associated(child)) then + call json%throw_exception(& + 'Error in json_value_get_child_by_name: '//& + 'Malformed JSON linked list',found) + exit + end if + if (allocated(child%name)) then + !name string matching routine: + if (json%name_equal(child,name)) then + error = .false. + exit + end if + end if + child => child%next + end do + end select + end associate end if if (error) then @@ -5695,6 +5785,7 @@ subroutine json_check_children_for_duplicate_keys(json,p,has_duplicate,name,path type(json_value),pointer :: child !! pointer to a child of `p` integer(IK) :: n_children !! number of children of `p` logical(LK) :: found !! flag for `get_child` + integer(IK) :: var_type !! var type of `p` type :: alloc_str !! so we can have an array of allocatable strings @@ -5706,79 +5797,72 @@ subroutine json_check_children_for_duplicate_keys(json,p,has_duplicate,name,path ! initialize: has_duplicate =.false. - if (.not. json%exception_thrown) then + if (json%exception_thrown) return + if (.not. associated(p)) return - if (associated(p)) then + call json%info(p,var_type=var_type,n_children=n_children) - if (p%var_type==json_object) then + if (var_type/=json_object) return - ! number of items to check: - n_children = json%count(p) - allocate(names(n_children)) + allocate(names(n_children)) - ! first get a list of all the name keys: - do i=1, n_children - call json%get_child(p,i,child,found) ! get by index - if (.not. found) then - call json%throw_exception(& - 'Error in json_check_children_for_duplicate_keys: '//& - 'Malformed JSON linked list') - exit - end if - if (allocated(child%name)) then - names(i)%str = child%name - else - call json%throw_exception(& - 'Error in json_check_children_for_duplicate_keys: '//& - 'Object child name is not allocated') - exit - end if - end do + ! first get a list of all the name keys: + do i=1, n_children + call json%get_child(p,i,child,found) ! get by index + if (.not. found) then + call json%throw_exception(& + 'Error in json_check_children_for_duplicate_keys: '//& + 'Malformed JSON linked list') + exit + end if + if (allocated(child%name)) then + names(i)%str = child%name + else + call json%throw_exception(& + 'Error in json_check_children_for_duplicate_keys: '//& + 'Object child name is not allocated') + exit + end if + end do - if (.not. json%exception_thrown) then - ! now check the list for duplicates: - main: do i=1,n_children - do j=1,i-1 - if (json%name_strings_equal(names(i)%str,names(j)%str)) then - has_duplicate = .true. - if (present(name)) then - name = names(i)%str - end if - if (present(path)) then - call json%get_child(p,names(i)%str,child,found) ! get by name - if (found) then - call json%get_path(child,path,found) - if (.not. found) then - ! should never happen since we know it is there - call json%throw_exception(& - 'Error in json_check_children_for_duplicate_keys: '//& - 'Could not get path') - end if - else - ! should never happen since we know it is there - call json%throw_exception(& - 'Error in json_check_children_for_duplicate_keys: '//& - 'Could not get child: '//trim(names(i)%str)) - end if - end if - exit main + if (.not. json%exception_thrown) then + ! now check the list for duplicates: + main: do i=1,n_children + do j=1,i-1 + if (json%name_strings_equal(names(i)%str,names(j)%str)) then + has_duplicate = .true. + if (present(name)) then + name = names(i)%str + end if + if (present(path)) then + call json%get_child(p,names(i)%str,child,found) ! get by name + if (found) then + call json%get_path(child,path,found) + if (.not. found) then + ! should never happen since we know it is there + call json%throw_exception(& + 'Error in json_check_children_for_duplicate_keys: '//& + 'Could not get path') end if - end do - end do main + else + ! should never happen since we know it is there + call json%throw_exception(& + 'Error in json_check_children_for_duplicate_keys: '//& + 'Could not get child: '//trim(names(i)%str)) + end if + end if + exit main end if - - ! cleanup - do i=1,n_children - if (allocated(names(i)%str)) deallocate(names(i)%str) - end do - if (allocated(names)) deallocate(names) - - end if - - end if - + end do + end do main end if + ! cleanup + do i=1,n_children + if (allocated(names(i)%str)) deallocate(names(i)%str) + end do + if (allocated(names)) deallocate(names) + end subroutine json_check_children_for_duplicate_keys !***************************************************************************************** @@ -5983,7 +6067,7 @@ subroutine json_print_to_filename(json,p,filename) close(iunit,iostat=istat) else call json%throw_exception('Error in json_print_to_filename: could not open file: '//& - trim(filename)) + trim(filename)) end if end subroutine json_print_to_filename @@ -6096,236 +6180,241 @@ recursive subroutine json_value_print(json,p,iunit,str,indent,& s_indent = repeat(space, spaces) end if - select case (p%var_type) - - case (json_object) + if (allocated(p%data)) then + associate (data => p%data) - count = json%count(p) + select type (data) - if (count==0) then !special case for empty object + class is (json_object_type) - s = s_indent//start_object//end_object - call write_it( comma=print_comma ) + count = json%count(p) - else - - s = s_indent//start_object - call write_it() + if (count==0) then !special case for empty object - !if an object is in an array, there is an extra tab: - if (is_array) then - if ( .not. json%no_whitespace) tab = tab+1 - spaces = tab*json%spaces_per_tab - end if + s = s_indent//start_object//end_object + call write_it( comma=print_comma ) - nullify(element) - element => p%children - do i = 1, count + else - if (.not. associated(element)) then - call json%throw_exception('Error in json_value_print: '//& - 'Malformed JSON linked list') - return - end if + s = s_indent//start_object + call write_it() - ! print the name - if (allocated(element%name)) then - call escape_string(element%name,str_escaped,json%escape_solidus) - if (json%no_whitespace) then - !compact printing - no extra space - s = repeat(space, spaces)//quotation_mark//& - str_escaped//quotation_mark//colon_char - call write_it(advance=.false.) - else - s = repeat(space, spaces)//quotation_mark//& - str_escaped//quotation_mark//colon_char//space - call write_it(advance=.false.) + !if an object is in an array, there is an extra tab: + if (is_array) then + if ( .not. json%no_whitespace) tab = tab+1 + spaces = tab*json%spaces_per_tab end if - else - call json%throw_exception('Error in json_value_print:'//& - ' element%name not allocated') - nullify(element) - return - end if - ! recursive print of the element - call json%json_value_print(element, iunit=iunit, indent=tab + 1_IK, & - need_comma=i element%next + nullify(element) + element => p%children + do i = 1, count - end do + if (.not. associated(element)) then + call json%throw_exception('Error in json_value_print: '//& + 'Malformed JSON linked list') + return + end if - ! [one fewer tab if it isn't an array element] - if (.not. is_array) then - s = repeat(space, max(0_IK,spaces-json%spaces_per_tab))//end_object - else - s = s_indent//end_object - end if - call write_it( comma=print_comma ) - nullify(element) + ! print the name + if (allocated(element%name)) then + call escape_string(element%name,str_escaped,json%escape_solidus) + if (json%no_whitespace) then + !compact printing - no extra space + s = repeat(space, spaces)//quotation_mark//& + str_escaped//quotation_mark//colon_char + call write_it(advance=.false.) + else + s = repeat(space, spaces)//quotation_mark//& + str_escaped//quotation_mark//colon_char//space + call write_it(advance=.false.) + end if + else + call json%throw_exception('Error in json_value_print:'//& + ' element%name not allocated') + nullify(element) + return + end if - end if + ! recursive print of the element + call json%json_value_print(element, iunit=iunit, indent=tab + 1_IK, & + need_comma=i element%next + + end do + + ! [one fewer tab if it isn't an array element] + if (.not. is_array) then + s = repeat(space, max(0_IK,spaces-json%spaces_per_tab))//end_object + else + s = s_indent//end_object + end if + call write_it( comma=print_comma ) + nullify(element) - case (json_array) - - count = json%count(p) - - if (json%compress_vectors) then - ! check to see if every child is the same type, - ! and a scalar: - is_vector = .true. - var_type_prev = -1 ! an invalid value - nullify(element) - element => p%children - do i = 1, count - if (.not. associated(element)) then - call json%throw_exception('Error in json_value_print: '//& - 'Malformed JSON linked list') - return end if - ! check variable type of all the children. - ! They must all be the same, and a scalar. - call json%info(element,var_type=var_type) - if (var_type==json_object .or. & - var_type==json_array .or. & - (i>1 .and. var_type/=var_type_prev)) then + + class is (json_array_type) + + count = json%count(p) + + if (json%compress_vectors) then + ! check to see if every child is the same type, + ! and a scalar: + is_vector = .true. + var_type_prev = -1 ! an invalid value + nullify(element) + element => p%children + do i = 1, count + if (.not. associated(element)) then + call json%throw_exception('Error in json_value_print: '//& + 'Malformed JSON linked list') + return + end if + ! check variable type of all the children. + ! They must all be the same, and a scalar. + call json%info(element,var_type=var_type) + if (var_type==json_object .or. & + var_type==json_array .or. & + (i>1 .and. var_type/=var_type_prev)) then + is_vector = .false. + exit + end if + var_type_prev = var_type + ! get the next child the list: + element => element%next + end do + else is_vector = .false. - exit end if - var_type_prev = var_type - ! get the next child the list: - element => element%next - end do - else - is_vector = .false. - end if - if (count==0) then !special case for empty array + if (count==0) then !special case for empty array - s = s_indent//start_array//end_array - call write_it( comma=print_comma ) + s = s_indent//start_array//end_array + call write_it( comma=print_comma ) - else + else - s = s_indent//start_array - call write_it( advance=(.not. is_vector) ) + s = s_indent//start_array + call write_it( advance=(.not. is_vector) ) - !if an array is in an array, there is an extra tab: - if (is_array) then - if ( .not. json%no_whitespace) tab = tab+1 - spaces = tab*json%spaces_per_tab - end if + !if an array is in an array, there is an extra tab: + if (is_array) then + if ( .not. json%no_whitespace) tab = tab+1 + spaces = tab*json%spaces_per_tab + end if - nullify(element) - element => p%children - do i = 1, count + nullify(element) + element => p%children + do i = 1, count - if (.not. associated(element)) then - call json%throw_exception('Error in json_value_print: '//& - 'Malformed JSON linked list') - return - end if + if (.not. associated(element)) then + call json%throw_exception('Error in json_value_print: '//& + 'Malformed JSON linked list') + return + end if - ! recursive print of the element - if (is_vector) then - call json%json_value_print(element, iunit=iunit, indent=0_IK,& - need_comma=i element%next + ! get the next child the list: + element => element%next - end do + end do - !indent the closing array character: - if (is_vector) then - s = end_array - call write_it( comma=print_comma ) - else - s = repeat(space, max(0_IK,spaces-json%spaces_per_tab))//end_array - call write_it( comma=print_comma ) - end if - nullify(element) + !indent the closing array character: + if (is_vector) then + s = end_array + call write_it( comma=print_comma ) + else + s = repeat(space, max(0_IK,spaces-json%spaces_per_tab))//end_array + call write_it( comma=print_comma ) + end if + nullify(element) - end if + end if - case (json_null) + class is (json_null_type) - s = s_indent//null_str - call write_it( comma=print_comma, & - advance=(.not. is_vector),& - space_after_comma=is_vector ) + s = s_indent//null_str + call write_it( comma=print_comma, & + advance=(.not. is_vector),& + space_after_comma=is_vector ) - case (json_string) + class is (json_string_type) - if (allocated(p%str_value)) then - ! have to escape the string for printing: - call escape_string(p%str_value,str_escaped,json%escape_solidus) - s = s_indent//quotation_mark//str_escaped//quotation_mark - call write_it( comma=print_comma, & - advance=(.not. is_vector),& - space_after_comma=is_vector ) - else - call json%throw_exception('Error in json_value_print:'//& - ' p%value_string not allocated') - return - end if + if (allocated(data%value)) then + ! have to escape the string for printing: + call escape_string(data%value,str_escaped,json%escape_solidus) + s = s_indent//quotation_mark//str_escaped//quotation_mark + call write_it( comma=print_comma, & + advance=(.not. is_vector),& + space_after_comma=is_vector ) + else + call json%throw_exception('Error in json_value_print:'//& + ' JSON string not allocated') + return + end if - case (json_logical) + class is (json_logical_type) - if (p%log_value) then - s = s_indent//true_str - call write_it( comma=print_comma, & - advance=(.not. is_vector),& - space_after_comma=is_vector ) - else - s = s_indent//false_str - call write_it( comma=print_comma, & - advance=(.not. is_vector),& - space_after_comma=is_vector ) - end if + if (data%value) then + s = s_indent//true_str + call write_it( comma=print_comma, & + advance=(.not. is_vector),& + space_after_comma=is_vector ) + else + s = s_indent//false_str + call write_it( comma=print_comma, & + advance=(.not. is_vector),& + space_after_comma=is_vector ) + end if - case (json_integer) + class is (json_integer_type) - call integer_to_string(p%int_value,int_fmt,tmp) + call integer_to_string(data%value,int_fmt,tmp) - s = s_indent//trim(tmp) - call write_it( comma=print_comma, & - advance=(.not. is_vector),& - space_after_comma=is_vector ) + s = s_indent//trim(tmp) + call write_it( comma=print_comma, & + advance=(.not. is_vector),& + space_after_comma=is_vector ) - case (json_real) + class is (json_real_type) - if (allocated(json%real_fmt)) then - call real_to_string(p%dbl_value,json%real_fmt,json%compact_real,json%non_normals_to_null,tmp) - else - !use the default format (user has not called initialize() or specified one): - call real_to_string(p%dbl_value,default_real_fmt,json%compact_real,json%non_normals_to_null,tmp) - end if + if (allocated(json%real_fmt)) then + call real_to_string(data%value,json%real_fmt,json%compact_real,json%non_normals_to_null,tmp) + else + !use the default format (user has not called initialize() or specified one): + call real_to_string(data%value,default_real_fmt,json%compact_real,json%non_normals_to_null,tmp) + end if - s = s_indent//trim(tmp) - call write_it( comma=print_comma, & - advance=(.not. is_vector),& - space_after_comma=is_vector ) + s = s_indent//trim(tmp) + call write_it( comma=print_comma, & + advance=(.not. is_vector),& + space_after_comma=is_vector ) - case default + class default + call json%throw_exception('Error in json_value_print: '//& + 'unknown data type') + end select - call integer_to_string(p%var_type,int_fmt,tmp) + end associate + else call json%throw_exception('Error in json_value_print: '//& - 'unknown data type: '//trim(tmp)) - - end select - + 'JSON data not allocated') + end if end if contains @@ -6491,7 +6580,7 @@ subroutine json_get_by_path(json, me, path, p, found) case default call integer_to_string(json%path_mode,int_fmt,path_mode_str) call json%throw_exception('Error in json_get_by_path: Unsupported path_mode: '//& - trim(path_mode_str)) + trim(path_mode_str)) if (present(found)) found = .false. end select @@ -6850,10 +6939,18 @@ subroutine json_get_by_path_default(json,me,path,p,found,create_it,was_created) ! What about the case: aaa.bbb(1)(3) ? ! Is that already handled? - if (p%var_type==json_null) then ! (**) - ! if p was also created, then we need to - ! convert it into an object here: - p%var_type = json_object + ! if p was also created, then we need to + ! convert it into an object here: + if (allocated(p%data)) then + associate (data => p%data) + select type (data) + class is (json_null_type) ! (**) + deallocate(p%data) + allocate(json_object_type :: p%data) + end select + end associate + else + allocate(json_object_type :: p%data) end if ! don't want to throw exceptions in this case @@ -6906,12 +7003,19 @@ subroutine json_get_by_path_default(json,me,path,p,found,create_it,was_created) call json%get_child(p, child_i, tmp, child_found) if (.not. child_found) then - if (p%var_type==json_null) then ! (**) - ! if p was also created, then we need to - ! convert it into an array here: - p%var_type = json_array + ! if p was also created, then we need to + ! convert it into an array here: + if (allocated(p%data)) then + associate (data => p%data) + select type (data) + class is (json_null_type) ! (**) + deallocate(p%data) + allocate(json_array_type :: p%data) + end select + end associate + else + allocate(json_array_type :: p%data) end if - ! have to create this element ! [make it a null] ! (and any missing ones before it) @@ -6949,10 +7053,18 @@ subroutine json_get_by_path_default(json,me,path,p,found,create_it,was_created) if (child_i < i) then nullify(tmp) if (create) then - if (p%var_type==json_null) then ! (**) - ! if p was also created, then we need to - ! convert it into an object here: - p%var_type = json_object + ! if p was also created, then we need to + ! convert it into an object here: + if (allocated(p%data)) then + associate (data => p%data) + select type (data) + class is (json_null_type) ! (**) + deallocate(p%data) + allocate(json_object_type :: p%data) + end select + end associate + else + allocate(json_object_type :: p%data) end if ! don't want to throw exceptions in this case @@ -7005,10 +7117,18 @@ subroutine json_get_by_path_default(json,me,path,p,found,create_it,was_created) if (child_i <= length) then nullify(tmp) if (create) then - if (p%var_type==json_null) then ! (**) - ! if p was also created, then we need to - ! convert it into an object here: - p%var_type = json_object + ! if p was also created, then we need to + ! convert it into an object here: + if (allocated(p%data)) then + associate (data => p%data) + select type (data) + class is (json_null_type) ! (**) + deallocate(p%data) + allocate(json_object_type :: p%data) + end select + end associate + else + allocate(json_object_type :: p%data) end if call json%get_child(p, path(child_i:i-1), tmp, child_found) @@ -7249,7 +7369,7 @@ subroutine json_get_by_path_rfc6901(json, me, path, p, found) else call json%throw_exception('Error in json_get_by_path_rfc6901: '//& - 'invalid path specification: '//trim(path),found) + 'invalid path specification: '//trim(path),found) end if end if @@ -7541,12 +7661,20 @@ subroutine json_get_by_path_jsonpath_bracket(json,me,path,p,found,create_it,was_ if (create .and. .not. status_ok) then ! have to create it: - - if (.not.(p%var_type==json_object .or. p%var_type==json_array)) then - ! we need to convert it into an array here - ! (e.g., if p was also just created) - ! and destroy its data to prevent a memory leak - call json%convert(p,json_array) + if (allocated(p%data)) then + associate (data => p%data) + select type (data) + class is (json_data_with_children) + ! already object or array + class default + ! we need to convert it into an array here + ! (e.g., if p was also just created) + ! and destroy its data to prevent a memory leak + call json%convert(p,json_array) + end select + end associate + else + allocate(json_array_type :: p%data) end if ! have to create this element @@ -7661,10 +7789,12 @@ subroutine convert(json,p,var_type) type(json_value),pointer :: tmp !! temporary variable character(kind=CK,len=:),allocatable :: name !! the name of a JSON variable - + integer(IK) :: p_var_type !! `var_type` of `p` logical :: convert_it !! if `p` needs to be converted - convert_it = p%var_type /= var_type + call json%info(p,var_type=p_var_type) + + convert_it = p_var_type /= var_type if (convert_it) then @@ -8108,37 +8238,42 @@ subroutine json_get_integer(json, me, value) value = 0_IK if ( json%exception_thrown ) return - if (me%var_type == json_integer) then - value = me%int_value - else - if (json%strict_type_checking) then - call json%throw_exception('Error in json_get_integer:'//& - ' Unable to resolve value to integer: '//me%name) - else - !type conversions - select case(me%var_type) - case (json_real) - value = int(me%dbl_value, IK) - case (json_logical) - if (me%log_value) then - value = 1_IK - else - value = 0_IK - end if - case (json_string) - call string_to_integer(me%str_value,value,status_ok) - if (.not. status_ok) then - value = 0_IK - call json%throw_exception('Error in json_get_integer:'//& - ' Unable to convert string value to integer: me.'//& - me%name//' = '//trim(me%str_value)) - end if - case default + associate (data => me%data) + + select type (data) + class is (json_integer_type) + value = data%value + class default + if (json%strict_type_checking) then call json%throw_exception('Error in json_get_integer:'//& - ' Unable to resolve value to integer: '//me%name) - end select - end if - end if + ' Unable to resolve value to integer: '//me%name) + else + !type conversions + select type (data) + class is (json_real_type) + value = int(data%value, IK) + class is (json_logical_type) + if (data%value) then + value = 1_IK + else + value = 0_IK + end if + class is (json_string_type) + call string_to_integer(data%value,value,status_ok) + if (.not. status_ok) then + value = 0_IK + call json%throw_exception('Error in json_get_integer:'//& + ' Unable to convert string value to integer: me.'//& + me%name//' = '//trim(data%value)) + end if + class default + call json%throw_exception('Error in json_get_integer:'//& + ' Unable to resolve value to integer: '//me%name) + end select + end if + end select + + end associate end subroutine json_get_integer !***************************************************************************************** @@ -8205,13 +8340,15 @@ subroutine json_get_integer_vec(json, me, vec) if ( json%exception_thrown ) return ! check for 0-length arrays first: - select case (me%var_type) - case (json_array) - if (json%count(me)==0) then - allocate(vec(0)) - return - end if - end select + associate (data => me%data) + select type (data) + class is (json_array_type) + if (json%count(me)==0) then + allocate(vec(0)) + return + end if + end select + end associate initialized = .false. @@ -8321,54 +8458,59 @@ subroutine json_get_real(json, me, value) value = 0.0_RK if ( json%exception_thrown ) return - if (me%var_type == json_real) then - value = me%dbl_value - else - if (json%strict_type_checking) then - call json%throw_exception('Error in json_get_real:'//& - ' Unable to resolve value to real: '//me%name) - else - !type conversions - select case (me%var_type) - case (json_integer) - value = real(me%int_value, RK) - case (json_logical) - if (me%log_value) then - value = 1.0_RK - else - value = 0.0_RK - end if - case (json_string) - call string_to_real(me%str_value,json%use_quiet_nan,value,status_ok) - if (.not. status_ok) then - value = 0.0_RK - call json%throw_exception('Error in json_get_real:'//& - ' Unable to convert string value to real: me.'//& - me%name//' = '//trim(me%str_value)) - end if - case (json_null) - if (ieee_support_nan(value) .and. json%null_to_real_mode/=1_IK) then - select case (json%null_to_real_mode) - case(2_IK) - if (json%use_quiet_nan) then - value = ieee_value(value,ieee_quiet_nan) - else - value = ieee_value(value,ieee_signaling_nan) - end if - case(3_IK) - value = 0.0_RK - end select - else - call json%throw_exception('Error in json_get_real:'//& - ' Cannot convert null to NaN: '//me%name) - end if - case default + associate (data => me%data) + select type (data) + class is (json_real_type) + value = real(data%value, RK) + class default + if (json%strict_type_checking) then call json%throw_exception('Error in json_get_real:'//& ' Unable to resolve value to real: '//me%name) - end select - end if - end if + else + !type conversions + select type (data) + class is (json_integer_type) + value = data%value + class is (json_logical_type) + if (data%value) then + value = 1.0_RK + else + value = 0.0_RK + end if + class is (json_string_type) + call string_to_real(data%value,json%use_quiet_nan,value,status_ok) + if (.not. status_ok) then + value = 0.0_RK + call json%throw_exception('Error in json_get_real:'//& + ' Unable to convert string value to real: me.'//& + me%name//' = '//trim(data%value)) + end if + class is (json_null_type) + if (ieee_support_nan(value) .and. json%null_to_real_mode/=1_IK) then + select case (json%null_to_real_mode) + case(2_IK) + if (json%use_quiet_nan) then + value = ieee_value(value,ieee_quiet_nan) + else + value = ieee_value(value,ieee_signaling_nan) + end if + case(3_IK) + value = 0.0_RK + end select + else + call json%throw_exception('Error in json_get_real:'//& + ' Cannot convert null to NaN: '//me%name) + end if + class default + + call json%throw_exception('Error in json_get_real:'//& + ' Unable to resolve value to real: '//me%name) + end select + end if + end select + + end associate end subroutine json_get_real !***************************************************************************************** @@ -8435,13 +8577,15 @@ subroutine json_get_real_vec(json, me, vec) if ( json%exception_thrown ) return ! check for 0-length arrays first: - select case (me%var_type) - case (json_array) - if (json%count(me)==0) then - allocate(vec(0)) - return - end if - end select + associate (data => me%data) + select type (data) + class is (json_array_type) + if (json%count(me)==0) then + allocate(vec(0)) + return + end if + end select + end associate initialized = .false. @@ -8811,29 +8955,34 @@ subroutine json_get_logical(json, me, value) value = .false. if ( json%exception_thrown ) return - if (me%var_type == json_logical) then - value = me%log_value - else - if (json%strict_type_checking) then - call json%throw_exception('Error in json_get_logical: '//& - 'Unable to resolve value to logical: '//& - me%name) - else - !type conversions - select case (me%var_type) - case (json_integer) - value = (me%int_value > 0_IK) - case (json_real) - value = (me%dbl_value > 0.0_RK) - case (json_string) - value = (me%str_value == true_str) - case default + associate (data => me%data) + + select type (data) + class is (json_logical_type) + value = data%value + class default + if (json%strict_type_checking) then call json%throw_exception('Error in json_get_logical: '//& 'Unable to resolve value to logical: '//& me%name) - end select - end if - end if + else + !type conversions + select type (data) + class is (json_integer_type) + value = (data%value > 0_IK) + class is (json_real_type) + value = (data%value > 0.0_RK) + class is (json_string_type) + value = (data%value == true_str) + class default + call json%throw_exception('Error in json_get_logical: '//& + 'Unable to resolve value to logical: '//& + me%name) + end select + end if + end select + + end associate end subroutine json_get_logical !***************************************************************************************** @@ -8900,13 +9049,15 @@ subroutine json_get_logical_vec(json, me, vec) if ( json%exception_thrown ) return ! check for 0-length arrays first: - select case (me%var_type) - case (json_array) - if (json%count(me)==0) then - allocate(vec(0)) - return - end if - end select + associate (data => me%data) + select type (data) + class is (json_array_type) + if (json%count(me)==0) then + allocate(vec(0)) + return + end if + end select + end associate initialized = .false. @@ -8997,74 +9148,63 @@ subroutine json_get_string(json, me, value) character(kind=CK,len=:),allocatable,intent(out) :: value value = CK_'' - if (.not. json%exception_thrown) then + if (json%exception_thrown) return - if (me%var_type == json_string) then + associate (data => me%data) - if (allocated(me%str_value)) then + select type (data) + class is (json_string_type) + + if (allocated(data%value)) then if (json%unescaped_strings) then ! default: it is stored already unescaped: - value = me%str_value + value = data%value else ! return the escaped version: - call escape_string(me%str_value, value, json%escape_solidus) + call escape_string(data%value, value, json%escape_solidus) end if else - call json%throw_exception('Error in json_get_string: '//& - 'me%str_value not allocated') + call json%throw_exception('Error in json_get_string: '//& + 'JSON string not allocated') end if - else + class default if (json%strict_type_checking) then call json%throw_exception('Error in json_get_string:'//& - ' Unable to resolve value to string: '//me%name) + ' Unable to resolve value to string: '//& + me%name) else - select case (me%var_type) + select type (data) - case (json_integer) + class is (json_integer_type) - if (allocated(me%int_value)) then - value = repeat(space, max_integer_str_len) - call integer_to_string(me%int_value,int_fmt,value) - value = trim(value) - else - call json%throw_exception('Error in json_get_string: '//& - 'me%int_value not allocated') - end if + value = repeat(space, max_integer_str_len) + call integer_to_string(data%value,int_fmt,value) + value = trim(value) - case (json_real) + class is (json_real_type) - if (allocated(me%dbl_value)) then - value = repeat(space, max_numeric_str_len) - call real_to_string(me%dbl_value,json%real_fmt,& - json%non_normals_to_null,& - json%compact_real,value) - value = trim(value) - else - call json%throw_exception('Error in json_get_string: '//& - 'me%int_value not allocated') - end if + value = repeat(space, max_numeric_str_len) + call real_to_string(data%value,json%real_fmt,& + json%non_normals_to_null,& + json%compact_real,value) + value = trim(value) - case (json_logical) + class is (json_logical_type) - if (allocated(me%log_value)) then - if (me%log_value) then - value = true_str - else - value = false_str - end if + if (data%value) then + value = true_str else - call json%throw_exception('Error in json_get_string: '//& - 'me%log_value not allocated') + value = false_str end if - case (json_null) + class is (json_null_type) value = null_str - case default + class default call json%throw_exception('Error in json_get_string: '//& 'Unable to resolve value to characters: '//& @@ -9073,9 +9213,9 @@ subroutine json_get_string(json, me, value) end select end if - end if + end select - end if + end associate end subroutine json_get_string !***************************************************************************************** @@ -9142,13 +9282,15 @@ subroutine json_get_string_vec(json, me, vec) if ( json%exception_thrown ) return ! check for 0-length arrays first: - select case (me%var_type) - case (json_array) - if (json%count(me)==0) then - allocate(vec(0)) - return - end if - end select + associate (data => me%data) + select type (data) + class is (json_array_type) + if (json%count(me)==0) then + allocate(vec(0)) + return + end if + end select + end associate initialized = .false. @@ -9267,14 +9409,16 @@ subroutine json_get_alloc_string_vec(json, me, vec, ilen) if ( json%exception_thrown ) return ! check for 0-length arrays first: - select case (me%var_type) - case (json_array) - if (json%count(me)==0) then - allocate(character(kind=CK,len=0) :: vec(0)) - allocate(ilen(0)) - return - end if - end select + associate (data => me%data) + select type (data) + class is (json_array_type) + if (json%count(me)==0) then + allocate(character(kind=CK,len=0) :: vec(0)) + allocate(ilen(0)) + return + end if + end select + end associate initialized = .false. @@ -9417,24 +9561,28 @@ recursive subroutine json_get_array(json, me, array_callback) if ( json%exception_thrown ) return - select case (me%var_type) - case (json_array) - count = json%count(me) - element => me%children - do i = 1, count ! callback for each child - if (.not. associated(element)) then - call json%throw_exception('Error in json_get_array: '//& - 'Malformed JSON linked list') - return - end if - call array_callback(json, element, i, count) - if (json%exception_thrown) exit - element => element%next - end do - case default - call json%throw_exception('Error in json_get_array:'//& - ' Resolved value is not an array ') - end select + associate (data => me%data) + + select type (data) + class is (json_array_type) + count = json%count(me) + element => me%children + do i = 1, count ! callback for each child + if (.not. associated(element)) then + call json%throw_exception('Error in json_get_array: '//& + 'Malformed JSON linked list') + return + end if + call array_callback(json, element, i, count) + if (json%exception_thrown) exit + element => element%next + end do + class default + call json%throw_exception('Error in json_get_array:'//& + ' Resolved value is not an array ') + end select + + end associate end subroutine json_get_array !***************************************************************************************** @@ -9474,28 +9622,45 @@ recursive subroutine traverse(p) integer(IK) :: icount !! number of children if (json%exception_thrown) return - call traverse_callback(json,p,finished) ! first call for this object - if (finished) return - - !for arrays and objects, have to also call for all children: - if (p%var_type==json_array .or. p%var_type==json_object) then - - icount = json%count(p) ! number of children - if (icount>0) then - element => p%children ! first one - do i = 1, icount ! call for each child - if (.not. associated(element)) then - call json%throw_exception('Error in json_traverse: '//& - 'Malformed JSON linked list') - return - end if - call traverse(element) - if (finished .or. json%exception_thrown) exit - element => element%next - end do - end if - nullify(element) + if (associated(p)) then + + call traverse_callback(json,p,finished) ! first call for this object + if (finished) return + + if (allocated(p%data)) then + !for arrays and objects, have to also call for all children: + associate (data => p%data) + + select type (data) + class is (json_data_with_children) ! array or object + + icount = json%count(p) ! number of children + if (icount>0) then + element => p%children ! first one + do i = 1, icount ! call for each child + if (.not. associated(element)) then + call json%throw_exception('Error in json_traverse: '//& + 'Malformed JSON linked list') + return + end if + call traverse(element) + if (finished .or. json%exception_thrown) exit + element => element%next + end do + end if + nullify(element) + + end select + + end associate + else + call json%throw_exception('Error in json_traverse: '//& + 'JSON data not allocated') + end if + else + call json%throw_exception('Error in json_traverse: '//& + 'Pointer is not associated') end if end subroutine traverse @@ -10075,18 +10240,20 @@ recursive subroutine parse_value(json, unit, str, value) ! string call json%to_string(value) !allocate class - select case (value%var_type) - case (json_string) + associate (data => value%data) + select type (data) + class is (json_string_type) #if defined __GFORTRAN__ - ! write to a tmp variable because of - ! a bug in 4.9 gfortran compiler. - call json%parse_string(unit,str,tmp) - value%str_value = tmp - if (allocated(tmp)) deallocate(tmp) + ! write to a tmp variable because of + ! a bug in 4.9 gfortran compiler. + call json%parse_string(unit,str,tmp) + data%value = tmp + if (allocated(tmp)) deallocate(tmp) #else - call json%parse_string(unit,str,value%str_value) + call json%parse_string(unit,str,data%value) #endif - end select + end select + end associate case (CK_'t') !true_str(1:1) gfortran bug work around @@ -10566,14 +10733,19 @@ subroutine to_logical(json,p,val,name) character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed. !set type and value: - call destroy_json_data(p) - p%var_type = json_logical - allocate(p%log_value) - if (present(val)) then - p%log_value = val - else - p%log_value = .false. !default value - end if + call json%destroy_json_data(p) + + allocate(json_logical_type :: p%data) + associate (data => p%data) + select type (data) + class is (json_logical_type) + if (present(val)) then + data%value = val + else + data%value = .false. !default value + end if + end select + end associate !name: if (present(name)) call json%rename(p,name) @@ -10597,14 +10769,19 @@ subroutine to_integer(json,p,val,name) character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed. !set type and value: - call destroy_json_data(p) - p%var_type = json_integer - allocate(p%int_value) - if (present(val)) then - p%int_value = val - else - p%int_value = 0_IK !default value - end if + call json%destroy_json_data(p) + + allocate(json_integer_type :: p%data) + associate (data => p%data) + select type (data) + class is (json_integer_type) + if (present(val)) then + data%value = val + else + data%value = 0_IK !default value + end if + end select + end associate !name: if (present(name)) call json%rename(p,name) @@ -10628,14 +10805,19 @@ subroutine to_real(json,p,val,name) character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed. !set type and value: - call destroy_json_data(p) - p%var_type = json_real - allocate(p%dbl_value) - if (present(val)) then - p%dbl_value = val - else - p%dbl_value = 0.0_RK !default value - end if + call json%destroy_json_data(p) + + allocate(json_real_type :: p%data) + associate (data => p%data) + select type (data) + class is (json_real_type) + if (present(val)) then + data%value = val + else + data%value = 0.0_RK !default value + end if + end select + end associate !name: if (present(name)) call json%rename(p,name) @@ -10671,33 +10853,41 @@ subroutine to_string(json,p,val,name,trim_str,adjustl_str) logical :: adjustl_string !! if the string is to be adjusted left !set type and value: - call destroy_json_data(p) - p%var_type = json_string - if (present(val)) then + call json%destroy_json_data(p) - if (present(trim_str)) then - trim_string = trim_str - else - trim_string = .false. - end if - if (present(adjustl_str)) then - adjustl_string = adjustl_str - else - adjustl_string = .false. - end if + allocate(json_string_type :: p%data) + associate (data => p%data) + select type (data) + class is (json_string_type) - if (trim_string .or. adjustl_string) then - str = val - if (adjustl_string) str = adjustl(str) - if (trim_string) str = trim(str) - p%str_value = str - else - p%str_value = val - end if + if (present(val)) then - else - p%str_value = CK_'' ! default value - end if + if (present(trim_str)) then + trim_string = trim_str + else + trim_string = .false. + end if + if (present(adjustl_str)) then + adjustl_string = adjustl_str + else + adjustl_string = .false. + end if + + if (trim_string .or. adjustl_string) then + str = val + if (adjustl_string) str = adjustl(str) + if (trim_string) str = trim(str) + data%value = str + else + data%value = val + end if + + else + data%value = CK_'' ! default value + end if + + end select + end associate !name: if (present(name)) call json%rename(p,name) @@ -10719,8 +10909,8 @@ subroutine to_null(json,p,name) character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed. !set type and value: - call destroy_json_data(p) - p%var_type = json_null + call json%destroy_json_data(p) + allocate(json_null_type :: p%data) !name: if (present(name)) call json%rename(p,name) @@ -10742,8 +10932,8 @@ subroutine to_object(json,p,name) character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed. !set type and value: - call destroy_json_data(p) - p%var_type = json_object + call json%destroy_json_data(p) + allocate(json_object_type :: p%data) !name: if (present(name)) call json%rename(p,name) @@ -10765,8 +10955,8 @@ subroutine to_array(json,p,name) character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed. !set type and value: - call destroy_json_data(p) - p%var_type = json_array + call json%destroy_json_data(p) + allocate(json_array_type :: p%data) !name: if (present(name)) call json%rename(p,name) @@ -10809,7 +10999,7 @@ recursive subroutine parse_object(json, unit, str, parent) skip_comments=json%allow_comments, popped=c) if (eof) then call json%throw_exception('Error in parse_object:'//& - ' Unexpected end of file while parsing start of object.') + ' Unexpected end of file while parsing start of object.') return else if (end_object == c) then ! end of an empty object @@ -10837,7 +11027,7 @@ recursive subroutine parse_object(json, unit, str, parent) skip_comments=json%allow_comments, popped=c) if (eof) then call json%throw_exception('Error in parse_object:'//& - ' Unexpected end of file while parsing object member.') + ' Unexpected end of file while parsing object member.') return else if (colon_char == c) then ! parse the value @@ -10859,7 +11049,7 @@ recursive subroutine parse_object(json, unit, str, parent) skip_comments=json%allow_comments, popped=c) if (eof) then call json%throw_exception('Error in parse_object: '//& - 'End of file encountered when parsing an object') + 'End of file encountered when parsing an object') return else if (delimiter == c) then ! read the next member @@ -10917,7 +11107,7 @@ recursive subroutine parse_array(json, unit, str, array) if (eof) then ! The file ended before array was finished: call json%throw_exception('Error in parse_array: '//& - 'End of file encountered when parsing an array.') + 'End of file encountered when parsing an array.') exit else if (delimiter == c) then ! parse the next element @@ -11061,12 +11251,12 @@ subroutine parse_for_chars(json, unit, str, chars) call json%pop_char(unit, str=str, eof=eof, skip_ws=.false., popped=c) if (eof) then call json%throw_exception('Error in parse_for_chars:'//& - ' Unexpected end of file while parsing.') + ' Unexpected end of file while parsing.') return else if (c /= chars(i:i)) then call json%throw_exception('Error in parse_for_chars:'//& - ' Unexpected character: "'//c//'" (expecting "'//& - chars(i:i)//'")') + ' Unexpected character: "'//c//'" (expecting "'//& + chars(i:i)//'")') return end if end do