diff --git a/src/json_parameters.F90 b/src/json_parameters.F90 index ebd33c8df4..546f10d39a 100644 --- a/src/json_parameters.F90 +++ b/src/json_parameters.F90 @@ -99,9 +99,9 @@ module json_parameters character(kind=CK,len=*),parameter :: false_str = CK_'false' !! JSON logical False string #endif - integer, private :: i_ !! just a counter for `control_chars` array - character(kind=CK,len=*),dimension(32),parameter :: control_chars = & - [(achar(i_,kind=CK),i_=1,31), achar(127,kind=CK)] !! Control characters, possibly in unicode + ! integer, private :: i_ !! just a counter for `control_chars` array + ! character(kind=CK,len=*),dimension(32),parameter :: control_chars = & + ! [(achar(i_,kind=CK),i_=1,31), achar(127,kind=CK)] !! Control characters, possibly in unicode !find out the precision of the floating point number system !and set safety factors diff --git a/src/json_string_utilities.F90 b/src/json_string_utilities.F90 index 74f2801bcb..6452f81c4d 100644 --- a/src/json_string_utilities.F90 +++ b/src/json_string_utilities.F90 @@ -64,6 +64,9 @@ module json_string_utilities public :: real_to_string public :: string_to_integer public :: string_to_real +#ifdef C_STR2REAL + public :: string_to_real_c +#endif public :: valid_json_hex public :: to_unicode public :: escape_string @@ -234,6 +237,7 @@ subroutine string_to_real(str,use_quiet_nan,rval,status_ok) integer(IK) :: ierr !! read iostat error code read(str,fmt=*,iostat=ierr) rval + status_ok = (ierr==0) if (.not. status_ok) then rval = 0.0_RK @@ -253,6 +257,135 @@ subroutine string_to_real(str,use_quiet_nan,rval,status_ok) end subroutine string_to_real !***************************************************************************************** +#ifdef C_STR2REAL +!***************************************************************************************** +!> author: Jacob Williams +! date: 11/05/2021 +! +! Convert a string into a `real(RK)`. +! This version uses `strtof`, `strtod`, or `strtold` from C. +! It will fall back to using `read(fmt=*)` if any errors. +! +!# History +! * Jacob Williams : 11/05/2021 : created by modification of [[string_to_real]]. + + subroutine string_to_real_c(str,use_quiet_nan,rval,status_ok) + + use iso_c_binding, only: c_double, c_float, c_long_double, & + c_char, c_ptr, c_null_ptr, c_long, & + c_null_char + + implicit none + + character(kind=CK,len=*),intent(in) :: str !! the string to convert to a real + logical(LK),intent(in) :: use_quiet_nan !! if true, return NaN's as `ieee_quiet_nan`. + !! otherwise, use `ieee_signaling_nan`. + real(RK),intent(out) :: rval !! `str` converted to a real value + logical(LK),intent(out) :: status_ok !! true if there were no errors + + integer(IK) :: ierr !! read iostat error code + type(c_ptr) :: endptr !! pointer arg to `strtof`, etc. + + interface + function strtof( str, endptr ) result(d) bind(C, name="strtof" ) + !! :: float strtof(const char *str, char **endptr) + import + character(kind=c_char,len=1),dimension(*),intent(in) :: str + type(c_ptr), intent(inout) :: endptr + real(c_float) :: d + end function strtof + function strtod( str, endptr ) result(d) bind(C, name="strtod" ) + !! :: double strtod(const char *str, char **endptr) + import + character(kind=c_char,len=1),dimension(*),intent(in) :: str + type(c_ptr), intent(inout) :: endptr + real(c_double) :: d + end function strtod + function strtold( str, endptr ) result(d) bind(C, name="strtold" ) + !! :: long double strtold(const char *str, char **endptr) + import + character(kind=c_char,len=1),dimension(*),intent(in) :: str + type(c_ptr), intent(inout) :: endptr + real(c_long_double) :: d + end function strtold + end interface + +#ifdef USE_UCS4 + ! if using unicode, don't try to call the C routines + ! [not sure they will work? need to test this... what if c_char /= CK?] + call string_to_real(str,use_quiet_nan,rval,status_ok) + return +#endif + + endptr = c_null_ptr ! indicates it is not used + +#ifdef REAL32 + + ! single precision + + if (RK == c_float) then + rval = strtof( str//C_NULL_CHAR, endptr ) + if (rval==0.0_RK) then + read(str,fmt=*,iostat=ierr) rval ! not efficient - might really be 0.0 + else + ierr = 0 + end if + else + read(str,fmt=*,iostat=ierr) rval + end if + +#elif REAL128 + + ! quad precision + + if (RK == c_long_double) then + rval = strtold( str//C_NULL_CHAR, endptr ) + if (rval==0.0_RK) then + read(str,fmt=*,iostat=ierr) rval ! not efficient - might really be 0.0 + else + ierr = 0 + end if + else + read(str,fmt=*,iostat=ierr) rval + end if + +#else + + ! double precision + + if (RK == c_double) then + rval = strtod( str//C_NULL_CHAR, endptr ) + if (rval==0.0_RK) then + read(str,fmt=*,iostat=ierr) rval ! not efficient - might really be 0.0 + else + ierr = 0 + end if + else + read(str,fmt=*,iostat=ierr) rval + end if + +#endif + + status_ok = (ierr==0) + if (.not. status_ok) then + rval = 0.0_RK + else + if (ieee_support_nan(rval)) then + if (ieee_is_nan(rval)) then + ! make sure to return the correct NaN + if (use_quiet_nan) then + rval = ieee_value(rval,ieee_quiet_nan) + else + rval = ieee_value(rval,ieee_signaling_nan) + end if + end if + end if + end if + + end subroutine string_to_real_c +!***************************************************************************************** +#endif + !***************************************************************************************** !> author: Izaak Beekman ! date: 02/24/2015 diff --git a/src/json_value_module.F90 b/src/json_value_module.F90 index 4bae98a3e4..ba63d78fd1 100644 --- a/src/json_value_module.F90 +++ b/src/json_value_module.F90 @@ -290,8 +290,8 @@ module json_value_module integer :: ichunk = 0 !! index in `chunk` for [[pop_char]] !! when `use_unformatted_stream=True` integer :: filesize = 0 !! the file size when when `use_unformatted_stream=True` - character(kind=CK,len=:),allocatable :: chunk !! a chunk read from a stream file - !! when `use_unformatted_stream=True` + character(kind=CK),dimension(:),allocatable :: chunk !! a chunk read from a stream file + !! when `use_unformatted_stream=True` contains @@ -1045,7 +1045,9 @@ subroutine json_initialize(me,& if (use_unformatted_stream) then me%filesize = 0 me%ichunk = 0 - me%chunk = repeat(space, stream_chunk_size) ! default chunk size + if (allocated(me%chunk)) deallocate(me%chunk) + allocate(me%chunk(stream_chunk_size)) ! default chunk size + me%chunk = space end if #ifdef USE_UCS4 @@ -3407,7 +3409,7 @@ subroutine json_value_add_member(json,p,member) if (associated(p)) then - call json%info(p,var_type=var_type) + var_type = p%var_type select case (var_type) case(json_object, json_array) @@ -8108,7 +8110,11 @@ function string_to_dble(json,str) result(rval) logical(LK) :: status_ok !! error flag for [[string_to_real]] +#ifdef C_STR2REAL + call string_to_real_c(str,json%use_quiet_nan,rval,status_ok) +#else call string_to_real(str,json%use_quiet_nan,rval,status_ok) +#endif if (.not. status_ok) then !if there was an error rval = 0.0_RK @@ -8389,7 +8395,11 @@ subroutine json_get_real(json, me, value) value = 0.0_RK end if case (json_string) +#ifdef C_STR2REAL + call string_to_real_c(me%str_value,json%use_quiet_nan,value,status_ok) +#else call string_to_real(me%str_value,json%use_quiet_nan,value,status_ok) +#endif if (.not. status_ok) then value = 0.0_RK if (allocated(me%name)) then @@ -9881,7 +9891,7 @@ subroutine json_parse_end(json, unit, str) ! pop the next non whitespace character off the file call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., & - skip_comments=json%allow_comments, popped=c) + skip_comments=json%allow_comments, c=c) if (.not. eof) then call json%throw_exception('Error in json_parse_end:'//& @@ -10130,7 +10140,7 @@ recursive subroutine parse_value(json, unit, str, value) ! pop the next non whitespace character off the file call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., & - skip_comments=json%allow_comments, popped=c) + skip_comments=json%allow_comments, c=c) if (eof) then return @@ -10895,7 +10905,7 @@ recursive subroutine parse_object(json, unit, str, parent) ! pair name call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., & - skip_comments=json%allow_comments, popped=c) + skip_comments=json%allow_comments, c=c) if (eof) then call json%throw_exception('Error in parse_object:'//& ' Unexpected end of file while parsing start of object.') @@ -10923,7 +10933,7 @@ recursive subroutine parse_object(json, unit, str, parent) ! pair value call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., & - skip_comments=json%allow_comments, popped=c) + skip_comments=json%allow_comments, c=c) if (eof) then call json%destroy(pair) call json%throw_exception('Error in parse_object:'//& @@ -10947,7 +10957,7 @@ recursive subroutine parse_object(json, unit, str, parent) ! another possible pair call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., & - skip_comments=json%allow_comments, popped=c) + skip_comments=json%allow_comments, c=c) if (eof) then call json%throw_exception('Error in parse_object: '//& 'End of file encountered when parsing an object') @@ -11003,7 +11013,7 @@ recursive subroutine parse_array(json, unit, str, array) ! popped the next character call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., & - skip_comments=json%allow_comments, popped=c) + skip_comments=json%allow_comments, c=c) if (eof) then ! The file ended before array was finished: @@ -11069,7 +11079,7 @@ subroutine parse_string(json, unit, str, string) do !get the next character from the file: - call json%pop_char(unit, str=str, eof=eof, skip_ws=.false., popped=c) + call json%pop_char(unit, str=str, eof=eof, skip_ws=.false., c=c) if (eof) then @@ -11149,15 +11159,15 @@ subroutine parse_for_chars(json, unit, str, chars) length = len_trim(chars) do i = 1, length - call json%pop_char(unit, str=str, eof=eof, skip_ws=.false., popped=c) + call json%pop_char(unit, str=str, eof=eof, skip_ws=.false., c=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 @@ -11198,10 +11208,13 @@ subroutine parse_number(json, unit, str, value) integer(IK) :: ip !! index to put next character !! [to speed up by reducing the number !! of character string reallocations] + integer(IK) :: ltmp !! length of `tmp` if (.not. json%exception_thrown) then - tmp = blank_chunk + ! can use the max number size here (it will be expanded if necessary) + tmp = repeat(space,max_numeric_str_len) + ltmp = max_numeric_str_len ip = 1 first = .true. is_integer = .true. !assume it may be an integer, unless otherwise determined @@ -11210,16 +11223,17 @@ subroutine parse_number(json, unit, str, value) do !get the next character: - call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., popped=c) + call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., c=c) select case (c) - case(CK_'-',CK_'+') !note: allowing a '+' as the first character here. - if (is_integer .and. (.not. first)) is_integer = .false. + case(CK_'0':CK_'9') !valid characters for numbers !add it to the string: - !tmp = tmp // c !...original - if (ip>len(tmp)) tmp = tmp // blank_chunk + if (ip>ltmp) then + tmp = tmp // blank_chunk + ltmp = len(tmp) + end if tmp(ip:ip) = c ip = ip + 1 @@ -11228,16 +11242,22 @@ subroutine parse_number(json, unit, str, value) if (is_integer) is_integer = .false. !add it to the string: - !tmp = tmp // c !...original - if (ip>len(tmp)) tmp = tmp // blank_chunk + if (ip>ltmp) then + tmp = tmp // blank_chunk + ltmp = len(tmp) + end if tmp(ip:ip) = c ip = ip + 1 - case(CK_'0':CK_'9') !valid characters for numbers + case(CK_'-',CK_'+') !note: allowing a '+' as the first character here. + + if (is_integer .and. (.not. first)) is_integer = .false. !add it to the string: - !tmp = tmp // c !...original - if (ip>len(tmp)) tmp = tmp // blank_chunk + if (ip>ltmp) then + tmp = tmp // blank_chunk + ltmp = len(tmp) + end if tmp(ip:ip) = c ip = ip + 1 @@ -11285,9 +11305,6 @@ subroutine parse_number(json, unit, str, value) end do - !cleanup: - if (allocated(tmp)) deallocate(tmp) - end if end subroutine parse_number @@ -11303,7 +11320,7 @@ end subroutine parse_number !@note This routine ignores non-printing ASCII characters ! (`iachar<=31`) that are in strings. - subroutine pop_char(json,unit,str,skip_ws,skip_comments,eof,popped) + subroutine pop_char(json,unit,str,skip_ws,skip_comments,eof,c) implicit none @@ -11316,15 +11333,14 @@ subroutine pop_char(json,unit,str,skip_ws,skip_comments,eof,popped) logical(LK),intent(in),optional :: skip_comments !! to ignore comment lines [default False] logical(LK),intent(out) :: eof !! true if the end of the file has !! been reached. - character(kind=CK,len=1),intent(out) :: popped !! the popped character returned + character(kind=CK,len=1),intent(out) :: c !! the popped character returned - integer(IK) :: ios !! `iostat` flag - integer(IK) :: str_len !! length of `str` - character(kind=CK,len=1) :: c !! a character read from the file (or string) - logical(LK) :: ignore !! if whitespace is to be ignored - logical(LK) :: ignore_comments !! if comment lines are to be ignored - logical(LK) :: parsing_comment !! if we are in the process - !! of parsing a comment line + integer(IK) :: ios !! `iostat` flag + logical(LK) :: ignore !! if whitespace is to be ignored + logical(LK) :: ignore_comments !! if comment lines are to be ignored + logical(LK) :: parsing_comment !! if we are in the process + !! of parsing a comment line + integer(IK) :: tmp !! local copy of `iachar(c)` if (.not. json%exception_thrown) then @@ -11365,23 +11381,25 @@ subroutine pop_char(json,unit,str,skip_ws,skip_comments,eof,popped) if (json%ichunk<1) then ! read in a chunk: json%ichunk = 0 - if (json%filesizelen(json%chunk)) then + if (json%ichunk>size(json%chunk)) then ! check this just in case ios = IOSTAT_END else ! get the next character from the chunk: - c = json%chunk(json%ichunk:json%ichunk) - if (json%ichunk==len(json%chunk)) then + c = json%chunk(json%ichunk) + if (json%ichunk==size(json%chunk)) then json%ichunk = 0 ! reset for next chunk end if end if @@ -11394,8 +11412,7 @@ subroutine pop_char(json,unit,str,skip_ws,skip_comments,eof,popped) else !read from the string - str_len = len(str) !length of the string - if (json%ipos<=str_len) then + if (json%ipos<=len(str)) then c = str(json%ipos:json%ipos) ios = 0 else @@ -11412,7 +11429,7 @@ subroutine pop_char(json,unit,str,skip_ws,skip_comments,eof,popped) ! no character to return json%char_count = 0 eof = .true. - popped = space ! just to set a value + c = space ! just to set a value exit else if (IS_IOSTAT_EOR(ios) .or. c==newline) then !end of record @@ -11426,32 +11443,30 @@ subroutine pop_char(json,unit,str,skip_ws,skip_comments,eof,popped) end if - if (ignore_comments .and. (parsing_comment .or. scan(c,json%comment_char,kind=IK)>0_IK) ) then - - ! skipping the comment - parsing_comment = .true. - cycle - - else if (any(c == control_chars)) then - - ! non printing ascii characters - cycle - - else if (ignore .and. c == space) then - - ! ignoring whitespace - cycle + if (ignore) then ! ignoring whitespace + if (c == space) cycle + end if - else + if (ignore_comments) then + if (parsing_comment) cycle ! still in the comment + if (scan(c,json%comment_char,kind=IK)>0_IK) then + ! start of comment, skipping it + parsing_comment = .true. + cycle + end if + end if - ! return the character - popped = c - exit + tmp = iachar(c,kind=IK) + ! skip non printing ascii characters [these are the control_chars] + if ( (tmp>=1 .and. tmp<=31) .or. (tmp==127)) cycle - end if + ! return the character c + exit end do + else + c = space end if end subroutine pop_char @@ -11489,12 +11504,12 @@ subroutine push_char(json,c) json%pushed_index = json%pushed_index + 1 - if (json%pushed_index>0 .and. json%pushed_index<=len(json%pushed_char)) then + if (json%pushed_index>0 .and. json%pushed_index<=pushed_char_size) then json%pushed_char(json%pushed_index:json%pushed_index) = c else call integer_to_string(json%pushed_index,int_fmt,istr) call json%throw_exception('Error in push_char: '//& - 'invalid valid of pushed_index: '//trim(istr)) + 'invalid value of pushed_index: '//trim(istr)) end if end if