Skip to content

Commit 7235278

Browse files
jacobwilliamsjacobwilliams
committed
Merge branch '491-error-messages' of https://github.com/jacobwilliams/json-fortran into develop
2 parents 09a1241 + f5bb9df commit 7235278

File tree

2 files changed

+200
-50
lines changed

2 files changed

+200
-50
lines changed

‎src/json_value_module.F90

Lines changed: 97 additions & 50 deletions
Original file line numberDiff line numberDiff line change
@@ -1321,7 +1321,7 @@ end subroutine json_clone
13211321
!@note If new data is added to the [[json_value]] type,
13221322
! then this would need to be updated.
13231323

1324-
recursive subroutine json_value_clone_func(from,to,parent,previous,next,children,tail)
1324+
recursive subroutine json_value_clone_func(from,to,parent,previous,tail)
13251325

13261326
implicit none
13271327

@@ -1330,8 +1330,6 @@ recursive subroutine json_value_clone_func(from,to,parent,previous,next,children
13301330
!! must not already be associated)
13311331
type(json_value),pointer,optional :: parent !! to%parent
13321332
type(json_value),pointer,optional :: previous !! to%previous
1333-
type(json_value),pointer,optional :: next !! to%next
1334-
type(json_value),pointer,optional :: children !! to%children
13351333
logical,optional :: tail !! if "to" is the tail of
13361334
!! its parent's children
13371335

@@ -1352,33 +1350,28 @@ recursive subroutine json_value_clone_func(from,to,parent,previous,next,children
13521350
to%var_type = from%var_type
13531351
to%n_children = from%n_children
13541352

1355-
!allocate and associate the pointers as necessary:
1356-
1357-
if (present(parent)) to%parent => parent
1358-
if (present(previous)) to%previous => previous
1359-
if (present(next)) to%next => next
1360-
if (present(children)) to%children => children
1353+
! allocate and associate the pointers as necessary:
1354+
if (present(parent)) to%parent => parent
1355+
if (present(previous)) to%previous => previous
13611356
if (present(tail)) then
13621357
if (tail .and. associated(to%parent)) to%parent%tail => to
13631358
end if
13641359

13651360
if (associated(from%next) .and. associated(to%parent)) then
13661361
! we only clone the next entry in an array
13671362
! if the parent has also been cloned
1368-
allocate(to%next)
1369-
call json_value_clone_func(from%next,&
1370-
to%next,&
1371-
previous=to,&
1372-
parent=to%parent,&
1373-
tail=(.not. associated(from%next%next)))
1363+
call json_value_clone_func(from = from%next,&
1364+
to = to%next,&
1365+
previous = to,&
1366+
parent = to%parent,&
1367+
tail = (.not. associated(from%next%next)))
13741368
end if
13751369

13761370
if (associated(from%children)) then
1377-
allocate(to%children)
1378-
call json_value_clone_func(from%children,&
1379-
to%children,&
1380-
parent=to,&
1381-
tail=(.not. associated(from%children%next)))
1371+
call json_value_clone_func(from = from%children,&
1372+
to = to%children,&
1373+
parent = to,&
1374+
tail = (.not. associated(from%children%next)))
13821375
end if
13831376

13841377
end if
@@ -8148,8 +8141,13 @@ subroutine json_get_integer(json, me, value)
81488141
value = me%int_value
81498142
else
81508143
if (json%strict_type_checking) then
8151-
call json%throw_exception('Error in json_get_integer:'//&
8152-
' Unable to resolve value to integer: '//me%name)
8144+
if (allocated(me%name)) then
8145+
call json%throw_exception('Error in json_get_integer:'//&
8146+
' Unable to resolve value to integer: '//me%name)
8147+
else
8148+
call json%throw_exception('Error in json_get_integer:'//&
8149+
' Unable to resolve value to integer')
8150+
end if
81538151
else
81548152
!type conversions
81558153
select case(me%var_type)
@@ -8165,13 +8163,24 @@ subroutine json_get_integer(json, me, value)
81658163
call string_to_integer(me%str_value,value,status_ok)
81668164
if (.not. status_ok) then
81678165
value = 0_IK
8168-
call json%throw_exception('Error in json_get_integer:'//&
8169-
' Unable to convert string value to integer: me.'//&
8170-
me%name//' = '//trim(me%str_value))
8166+
if (allocated(me%name)) then
8167+
call json%throw_exception('Error in json_get_integer:'//&
8168+
' Unable to convert string value to integer: '//&
8169+
me%name//' = '//trim(me%str_value))
8170+
else
8171+
call json%throw_exception('Error in json_get_integer:'//&
8172+
' Unable to convert string value to integer: '//&
8173+
trim(me%str_value))
8174+
end if
81718175
end if
81728176
case default
8173-
call json%throw_exception('Error in json_get_integer:'//&
8174-
' Unable to resolve value to integer: '//me%name)
8177+
if (allocated(me%name)) then
8178+
call json%throw_exception('Error in json_get_integer:'//&
8179+
' Unable to resolve value to integer: '//me%name)
8180+
else
8181+
call json%throw_exception('Error in json_get_integer:'//&
8182+
' Unable to resolve value to integer')
8183+
end if
81758184
end select
81768185
end if
81778186
end if
@@ -8361,8 +8370,13 @@ subroutine json_get_real(json, me, value)
83618370
value = me%dbl_value
83628371
else
83638372
if (json%strict_type_checking) then
8364-
call json%throw_exception('Error in json_get_real:'//&
8365-
' Unable to resolve value to real: '//me%name)
8373+
if (allocated(me%name)) then
8374+
call json%throw_exception('Error in json_get_real:'//&
8375+
' Unable to resolve value to real: '//me%name)
8376+
else
8377+
call json%throw_exception('Error in json_get_real:'//&
8378+
' Unable to resolve value to real')
8379+
end if
83668380
else
83678381
!type conversions
83688382
select case (me%var_type)
@@ -8378,9 +8392,15 @@ subroutine json_get_real(json, me, value)
83788392
call string_to_real(me%str_value,json%use_quiet_nan,value,status_ok)
83798393
if (.not. status_ok) then
83808394
value = 0.0_RK
8381-
call json%throw_exception('Error in json_get_real:'//&
8382-
' Unable to convert string value to real: me.'//&
8383-
me%name//' = '//trim(me%str_value))
8395+
if (allocated(me%name)) then
8396+
call json%throw_exception('Error in json_get_real:'//&
8397+
' Unable to convert string value to real: '//&
8398+
me%name//' = '//trim(me%str_value))
8399+
else
8400+
call json%throw_exception('Error in json_get_real:'//&
8401+
' Unable to convert string value to real: '//&
8402+
trim(me%str_value))
8403+
end if
83848404
end if
83858405
case (json_null)
83868406
if (ieee_support_nan(value) .and. json%null_to_real_mode/=1_IK) then
@@ -8395,13 +8415,22 @@ subroutine json_get_real(json, me, value)
83958415
value = 0.0_RK
83968416
end select
83978417
else
8398-
call json%throw_exception('Error in json_get_real:'//&
8399-
' Cannot convert null to NaN: '//me%name)
8418+
if (allocated(me%name)) then
8419+
call json%throw_exception('Error in json_get_real:'//&
8420+
' Cannot convert null to NaN: '//me%name)
8421+
else
8422+
call json%throw_exception('Error in json_get_real:'//&
8423+
' Cannot convert null to NaN')
8424+
end if
84008425
end if
84018426
case default
8402-
8403-
call json%throw_exception('Error in json_get_real:'//&
8404-
' Unable to resolve value to real: '//me%name)
8427+
if (allocated(me%name)) then
8428+
call json%throw_exception('Error in json_get_real:'//&
8429+
' Unable to resolve value to real: '//me%name)
8430+
else
8431+
call json%throw_exception('Error in json_get_real:'//&
8432+
' Unable to resolve value to real')
8433+
end if
84058434
end select
84068435
end if
84078436
end if
@@ -8851,9 +8880,14 @@ subroutine json_get_logical(json, me, value)
88518880
value = me%log_value
88528881
else
88538882
if (json%strict_type_checking) then
8854-
call json%throw_exception('Error in json_get_logical: '//&
8855-
'Unable to resolve value to logical: '//&
8856-
me%name)
8883+
if (allocated(me%name)) then
8884+
call json%throw_exception('Error in json_get_logical: '//&
8885+
'Unable to resolve value to logical: '//&
8886+
me%name)
8887+
else
8888+
call json%throw_exception('Error in json_get_logical: '//&
8889+
'Unable to resolve value to logical')
8890+
end if
88578891
else
88588892
!type conversions
88598893
select case (me%var_type)
@@ -8864,9 +8898,14 @@ subroutine json_get_logical(json, me, value)
88648898
case (json_string)
88658899
value = (me%str_value == true_str)
88668900
case default
8867-
call json%throw_exception('Error in json_get_logical: '//&
8868-
'Unable to resolve value to logical: '//&
8869-
me%name)
8901+
if (allocated(me%name)) then
8902+
call json%throw_exception('Error in json_get_logical: '//&
8903+
'Unable to resolve value to logical: '//&
8904+
me%name)
8905+
else
8906+
call json%throw_exception('Error in json_get_logical: '//&
8907+
'Unable to resolve value to logical')
8908+
end if
88708909
end select
88718910
end if
88728911
end if
@@ -9053,8 +9092,13 @@ subroutine json_get_string(json, me, value)
90539092
else
90549093

90559094
if (json%strict_type_checking) then
9056-
call json%throw_exception('Error in json_get_string:'//&
9057-
' Unable to resolve value to string: '//me%name)
9095+
if (allocated(me%name)) then
9096+
call json%throw_exception('Error in json_get_string:'//&
9097+
' Unable to resolve value to string: '//me%name)
9098+
else
9099+
call json%throw_exception('Error in json_get_string:'//&
9100+
' Unable to resolve value to string')
9101+
end if
90589102
else
90599103

90609104
select case (me%var_type)
@@ -9101,11 +9145,14 @@ subroutine json_get_string(json, me, value)
91019145
value = null_str
91029146

91039147
case default
9104-
9105-
call json%throw_exception('Error in json_get_string: '//&
9106-
'Unable to resolve value to characters: '//&
9107-
me%name)
9108-
9148+
if (allocated(me%name)) then
9149+
call json%throw_exception('Error in json_get_string: '//&
9150+
'Unable to resolve value to characters: '//&
9151+
me%name)
9152+
else
9153+
call json%throw_exception('Error in json_get_string: '//&
9154+
'Unable to resolve value to characters')
9155+
end if
91099156
end select
91109157

91119158
end if

‎src/tests/jf_test_48.F90

Lines changed: 103 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,103 @@
1+
!*****************************************************************************************
2+
!>
3+
! Module for the 48th unit test.
4+
5+
module jf_test_48_mod
6+
7+
use json_module, wp => json_RK, IK => json_IK, LK => json_LK
8+
use, intrinsic :: iso_fortran_env , only: error_unit, output_unit
9+
10+
implicit none
11+
12+
private
13+
public :: test_48
14+
15+
character(len=*),parameter :: filename = '../files/inputs/big.json' !! large file to open
16+
17+
contains
18+
19+
subroutine test_48(error_cnt)
20+
21+
!! Clone test
22+
23+
implicit none
24+
25+
integer,intent(out) :: error_cnt
26+
27+
type(json_value),pointer :: p, p_clone
28+
type(json_core) :: json !! factory for manipulating `json_value` pointers
29+
30+
write(error_unit,'(A)') ''
31+
write(error_unit,'(A)') '================================='
32+
write(error_unit,'(A)') ' EXAMPLE 48'
33+
write(error_unit,'(A)') '================================='
34+
write(error_unit,'(A)') ''
35+
36+
error_cnt = 0
37+
call json%initialize()
38+
if (json%failed()) then
39+
call json%print_error_message(error_unit)
40+
error_cnt = error_cnt + 1
41+
end if
42+
43+
write(error_unit,'(A)') 'open file'
44+
call json%load(filename, p)
45+
if (json%failed()) then
46+
call json%print_error_message(error_unit)
47+
error_cnt = error_cnt + 1
48+
end if
49+
50+
!test the deep copy routine:
51+
write(error_unit,'(A)') 'json_clone test'
52+
call json%clone(p,p_clone)
53+
if (json%failed()) then
54+
call json%print_error_message(error_unit)
55+
error_cnt = error_cnt + 1
56+
end if
57+
58+
call json%destroy(p)
59+
if (json%failed()) then
60+
call json%print_error_message(error_unit)
61+
error_cnt = error_cnt + 1
62+
end if
63+
64+
call json%destroy(p_clone)
65+
if (json%failed()) then
66+
call json%print_error_message(error_unit)
67+
error_cnt = error_cnt + 1
68+
end if
69+
70+
if (error_cnt==0) then
71+
write(error_unit,'(A)') 'Success'
72+
else
73+
write(error_unit,'(A)') 'Failed'
74+
end if
75+
76+
write(error_unit,'(A)') ''
77+
78+
end subroutine test_48
79+
80+
end module jf_test_48_mod
81+
!*****************************************************************************************
82+
83+
!*****************************************************************************************
84+
#ifndef INTEGRATED_TESTS
85+
program jf_test_48
86+
87+
!! clone test
88+
89+
use jf_test_48_mod , only: test_48
90+
implicit none
91+
integer :: n_errors
92+
integer :: i !! counter
93+
94+
integer,parameter :: n_repeat = 1 !! number of times to repeat the test
95+
96+
do i = 1, n_repeat
97+
call test_48(n_errors)
98+
if (n_errors /= 0) stop 1
99+
end do
100+
101+
end program jf_test_48
102+
#endif
103+
!*****************************************************************************************

0 commit comments

Comments
 (0)