Skip to content

Commit 5a96562

Browse files
davidpfisterdavidpfister
authored
Bugs/fixes #12 (#13)
* removing %tmp * fixing unit tests * Create conversion.f90
1 parent 54ed7a9 commit 5a96562

12 files changed

+1099
-823
lines changed

‎src/CMakeLists.txt‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
set(SRC
2+
conversion.f90
23
exceptions.f90
34
symengine_interface.f90
45
symengine_basic.f90

‎src/constants.f90‎

Lines changed: 0 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -11,35 +11,30 @@ function pi()
1111
type(basic) :: pi
1212
pi = Basic()
1313
call c_basic_const_pi(pi%ptr)
14-
pi%tmp = .true.
1514
end function
1615

1716
function e()
1817
type(basic) :: e
1918
e = Basic()
2019
call c_basic_const_e(e%ptr)
21-
e%tmp = .true.
2220
end function
2321

2422
function eulergamma() result(res)
2523
type(basic) :: res
2624
res = Basic()
2725
call c_basic_const_euler_gamma(res%ptr)
28-
res%tmp = .true.
2926
end function
3027

3128
function catalan() result(res)
3229
type(basic) :: res
3330
res = Basic()
3431
call c_basic_const_catalan(res%ptr)
35-
res%tmp = .true.
3632
end function
3733

3834
function goldenratio() result(res)
3935
type(basic) :: res
4036
res = Basic()
4137
call c_basic_const_goldenratio(res%ptr)
42-
res%tmp = .true.
4338
end function
4439

4540

‎src/conversion.f90‎

Lines changed: 237 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,237 @@
1+
module conversion
2+
use, intrinsic :: ieee_arithmetic, only: ieee_value, ieee_positive_inf, ieee_quiet_nan
3+
use, intrinsic :: iso_fortran_env, only: i1 => int8, i2 => int16, i4 => int32, i8 => int64, &
4+
r4 => real32, r8 => real64, r16 => real128
5+
implicit none
6+
private
7+
public :: cint, cint_p
8+
public :: cdbl, cdbl_p
9+
10+
integer(kind=i2), parameter :: zero = 0_i2
11+
integer(kind=i2), parameter :: one = 1_i2
12+
integer(kind=i2), parameter :: nine = 9_i2
13+
integer(kind=i2), parameter :: digit_0 = ichar('0',kind=i2)
14+
integer(kind=i2), parameter :: period = ichar('.',kind=i2) - digit_0
15+
integer(kind=i2), parameter :: comma = ichar(',',kind=i2) - digit_0
16+
integer(kind=i2), parameter :: minus_sign = ichar('-',kind=i2) - digit_0
17+
integer(kind=i2), parameter :: plus_sign = ichar('+',kind=i2) - digit_0
18+
integer(kind=i2), parameter :: Inf = ichar('I',kind=i2)
19+
integer(kind=i2), parameter :: NaN = ichar('N',kind=i2)
20+
integer(kind=i2), parameter :: le = ichar('e',kind=i2) - digit_0
21+
integer(kind=i2), parameter :: BE = ichar('E',kind=i2) - digit_0
22+
integer(kind=i2), parameter :: ld = ichar('d',kind=i2) - digit_0
23+
integer(kind=i2), parameter :: BD = ichar('D',kind=i2) - digit_0
24+
integer(kind=i2), parameter :: LF = 10, CR = 13, WS = 32
25+
26+
integer(kind=i2), parameter :: nwnb = 40 !> number of whole number factors
27+
integer(kind=i2), parameter :: nfnb = 40 !> number of fractional number factors
28+
real(r8), parameter :: whole_number_base(nwnb) = &
29+
[1d39, 1d38, 1d37, 1d36, 1d35, 1d34, 1d33, 1d32, &
30+
1d31, 1d30, 1d29, 1d28, 1d27, 1d26, 1d25, 1d24, &
31+
1d23, 1d22, 1d21, 1d20, 1d19, 1d18, 1d17, 1d16, &
32+
1d15, 1d14, 1d13, 1d12, 1d11, 1d10, 1d9, 1d8, &
33+
1d7, 1d6, 1d5, 1d4, 1d3, 1d2, 1d1, 1d0]
34+
real(r8), parameter :: fractional_base(nfnb) = &
35+
[1d-1, 1d-2, 1d-3, 1d-4, 1d-5, 1d-6, 1d-7, 1d-8, &
36+
1d-9, 1d-10, 1d-11, 1d-12, 1d-13, 1d-14, 1d-15, 1d-16, &
37+
1d-17, 1d-18, 1d-19, 1d-20, 1d-21, 1d-22, 1d-23, 1d-24, &
38+
1d-25, 1d-26, 1d-27, 1d-28, 1d-29, 1d-30, 1d-31, 1d-32, &
39+
1d-33, 1d-34, 1d-35, 1d-36, 1d-37, 1d-38, 1d-39, 1d-40 ]
40+
real(r8), parameter :: period_skip = 0d0
41+
real(r8), parameter :: expbase(nwnb+nfnb) = [whole_number_base, fractional_base]
42+
43+
contains
44+
45+
!---------------------------------------------
46+
! String To Integer implementations
47+
!---------------------------------------------
48+
elemental function cint(s) result(int)
49+
! -- In/out Variables
50+
character(*), intent(in) :: s !> input string
51+
integer :: int !> output integer value
52+
!private
53+
integer(1) :: p !> position within the number
54+
integer(1) :: stat ! error status
55+
56+
call cint32(s,int,p,stat)
57+
end function
58+
59+
function cint_p(s,stat) result(int)
60+
character(:), pointer :: s !> input string
61+
integer :: int !> output integer value
62+
integer(1),intent(inout), optional :: stat
63+
!private
64+
integer(1) :: p !> position within the number
65+
integer(1) :: err
66+
67+
call cint32(s,int,p,err)
68+
p = min( p , len(s) )
69+
s => s(p:)
70+
if(present(stat)) stat = err
71+
end function
72+
73+
elemental subroutine cint32(s,int,p,stat)
74+
!> Return an unsigned 32-bit integer
75+
! -- In/out Variables
76+
character(*), intent(in) :: s !> input string
77+
integer, intent(inout) :: int !> output integer value
78+
integer(1), intent(out) :: p !> position within the number
79+
integer(1), intent(out) :: stat !> status upon succes of failure to read
80+
!private
81+
integer(1) :: val
82+
83+
stat = 23 !> initialize error status with any number > 0
84+
85+
! Find first non white space
86+
p = mvs2nwsp(s)
87+
88+
int = 0
89+
do while( p<=len(s) )
90+
val = iachar(s(p:p))-digit_0
91+
if( val >= 0 .and. val <= 9) then
92+
int = int*10 + val ; p = p + 1
93+
else
94+
exit
95+
end if
96+
end do
97+
stat = 0
98+
end subroutine
99+
100+
!---------------------------------------------
101+
! String To Real function interfaces
102+
!---------------------------------------------
103+
104+
elemental function cdbl(s) result(r)
105+
! -- In/out Variables
106+
character(*), intent(in) :: s !> input string
107+
real(r8) :: r !> Output real value
108+
!private
109+
integer(1) :: p !> position within the number
110+
integer(1) :: stat ! error status
111+
112+
call cdbl_dp(s,r,p,stat)
113+
end function
114+
115+
function cdbl_p(s,stat) result(r)
116+
! -- In/out Variables
117+
character(:), pointer :: s !> input string
118+
real(r8) :: r !> Output real value
119+
integer(1),intent(inout), optional :: stat
120+
!private
121+
integer(1) :: p !> position within the number
122+
integer(1) :: err
123+
124+
call cdbl_dp(s,r,p,err)
125+
p = min( p , len(s) )
126+
s => s(p:)
127+
if(present(stat)) stat = err
128+
end function
129+
130+
!---------------------------------------------
131+
! String To Real implementations
132+
!---------------------------------------------
133+
134+
elemental subroutine cdbl_dp(s,r,p,stat)
135+
!> Sequentially unroll the character and get the sub integers composing the whole number, fraction and exponent
136+
! -- In/out Variables
137+
character(*), intent(in) :: s !> input string
138+
real(r8), intent(inout) :: r !> Output real value
139+
integer(1), intent(out) :: p !> last position within the string
140+
integer(1), intent(out) :: stat !> status upon success or failure to read
141+
!private
142+
integer(1) :: sign, sige !> sign of integer number and exponential
143+
integer(r8) :: int_r8 !> long integer to capture fractional part
144+
integer :: i_exp !> integer to capture whole number part
145+
integer(1) :: i, pP, pE, val , resp
146+
147+
stat = 23 !> initialize error status with any number > 0
148+
149+
! Find first non white space
150+
p = mvs2nwsp(s)
151+
152+
! Verify leading negative
153+
sign = 1
154+
if( iachar(s(p:p)) == minus_sign+digit_0 ) then
155+
sign = -1 ; p = p + 1
156+
end if
157+
if( iachar(s(p:p)) == Inf ) then
158+
r = sign*ieee_value(r, ieee_positive_inf); return
159+
else if( iachar(s(p:p)) == NaN ) then
160+
r = ieee_value(r, ieee_quiet_nan); return
161+
end if
162+
163+
! read whole and fractional number in a single integer
164+
pP = 127
165+
int_r8 = 0
166+
do i = p, min(19+p-1,len(s))
167+
val = iachar(s(i:i))-digit_0
168+
if( val >= 0 .and. val <= 9 ) then
169+
int_r8 = int_r8*10 + val
170+
else if( val == period ) then
171+
pP = i
172+
else
173+
exit
174+
end if
175+
end do
176+
pE = i ! Fix the exponent position
177+
do while( i<=len(s) )
178+
val = iachar(s(i:i))-digit_0
179+
if( val < 0 .or. val > 9 ) exit
180+
i = i + 1
181+
end do
182+
p = i
183+
resp = pE-min(pP,p) ! If no decimal indicator found it is taken as being in the current p position
184+
if( resp <= 0 ) resp = resp+1
185+
186+
! Get exponential
187+
sige = 1
188+
if( p<len(s) ) then
189+
if( any([le,BE,ld,BD]+digit_0==iachar(s(p:p))) ) p = p + 1
190+
if( iachar(s(p:p)) == minus_sign+digit_0 ) then
191+
sige = -1
192+
p = p + 1
193+
else if( iachar(s(p:p)) == plus_sign+digit_0 ) then
194+
p = p + 1
195+
end if
196+
end if
197+
198+
i_exp = 0
199+
do while( p<=len(s) )
200+
val = iachar(s(p:p))-digit_0
201+
if( val >= 0 .and. val <= 9) then
202+
i_exp = i_exp*10_i2 + val ; p = p + 1
203+
else
204+
exit
205+
end if
206+
end do
207+
208+
r = sign*int_r8*expbase(nwnb-1+resp-sige*max(0,i_exp))
209+
stat = 0
210+
end subroutine
211+
212+
!---------------------------------------------
213+
! Utility functions
214+
!---------------------------------------------
215+
216+
elemental function mvs2nwsp(s) result(p)
217+
!> get position of the next non white space character
218+
character(*),intent(in) :: s !> character chain
219+
integer(1) :: p !> position
220+
221+
p = 1
222+
do while( p<len(s) .and. (iachar(s(p:p))==WS.or.iachar(s(p:p))==LF.or.iachar(s(p:p))==CR) )
223+
p = p + 1
224+
end do
225+
end function
226+
227+
elemental function mvs2wsp(s) result(p)
228+
!> get position of the next white space character
229+
character(*),intent(in) :: s !> character chain
230+
integer(1) :: p !> position
231+
232+
p = 1
233+
do while( p<len(s) .and. .not.(iachar(s(p:p))==WS.or.iachar(s(p:p))==LF.or.iachar(s(p:p))==CR) )
234+
p = p + 1
235+
end do
236+
end function
237+
end module

0 commit comments

Comments
 (0)