Skip to content

Commit f2c739f

Browse files
jacobwilliamsjacobwilliams
committed
added pi() and if() functions
Fixes #11 added some more unit tests. also increased the tol for comparisons since some expressions are not exactly equal depending on optimization level. see also #9
1 parent 1d9fa34 commit f2c739f

File tree

2 files changed

+137
-68
lines changed

2 files changed

+137
-68
lines changed

‎src/function_parser.f90

Lines changed: 51 additions & 41 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,7 @@ module function_parser
3535
!parameters:
3636
real(wp), parameter :: zero = 0.0_wp
3737
real(wp), parameter :: one = 1.0_wp
38+
real(wp), parameter :: pi = acos(-one)
3839

3940
! Note: these should be continuous, unique integers:
4041
! [they must have the values that correspond to the array indices below]
@@ -60,8 +61,8 @@ module function_parser
6061
cAcos = 20, &
6162
cAtan2 = 21, & ! atan2 must precede atan to prevent aliasing.
6263
cAtan = 22, &
63-
cTest0 = 23, & ! Test function with 0 arguments (returns 15.0).
64-
cTest3 = 24 ! Test function with 3 arguments (returns sum of arguments).
64+
cPi = 23, & ! Pi (function with zero arguments)
65+
cIf = 24 ! Test function with 3 arguments (returns sum of arguments).
6566
integer, parameter :: VarBegin = 25
6667

6768
character(len=1), dimension(cAdd:cPow), parameter :: operators = [ '+', & ! plus
@@ -70,7 +71,7 @@ module function_parser
7071
'/', & ! divide
7172
'^' ] ! power
7273

73-
character(len=5), dimension(cAbs:cTest3), parameter :: functions = [ 'abs ', &
74+
character(len=5), dimension(cAbs:cIf), parameter :: functions = [ 'abs ', &
7475
'exp ', &
7576
'log10', &
7677
'log ', &
@@ -85,11 +86,11 @@ module function_parser
8586
'acos ', &
8687
'atan2', &
8788
'atan ', &
88-
'test0', &
89-
'test3' ]
89+
'pi ', &
90+
'if ' ]
9091

9192
! Specify the number of required arguments each `functions` element must have.
92-
integer, dimension(cAbs:cTest3), parameter :: required_args = [ 1, & ! abs
93+
integer, dimension(cAbs:cIf), parameter :: required_args = [ 1, & ! abs
9394
1, & ! exp
9495
1, & ! log10
9596
1, & ! log
@@ -104,11 +105,11 @@ module function_parser
104105
1, & ! acos
105106
2, & ! atan2
106107
1, & ! atan
107-
0, & ! test0
108-
3 ] ! test3
108+
0, & ! pi
109+
3 ] ! if
109110

110111
! Specify the number of optional arguments each `functions` element might have.
111-
integer, dimension(cAbs:cTest3), parameter :: optional_args = [ 0, & ! abs
112+
integer, dimension(cAbs:cIf), parameter :: optional_args = [ 0, & ! abs
112113
0, & ! exp
113114
0, & ! log10
114115
0, & ! log
@@ -123,8 +124,8 @@ module function_parser
123124
0, & ! acos
124125
0, & ! atan2
125126
1, & ! atan
126-
0, & ! test0
127-
0 ] ! test3
127+
0, & ! pi
128+
0 ] ! if
128129

129130
! The maximum number of arguments any `functions` element might have.
130131
integer, parameter :: max_func_args = maxval(required_args + optional_args)
@@ -1042,9 +1043,9 @@ end subroutine catan2_func
10421043

10431044
!******************************************************************
10441045
!>
1045-
! Test function with zero arguments.
1046+
! Pi. A function with zero arguments.
10461047

1047-
subroutine ctest0_func(me,ip,dp,sp,val,ierr)
1048+
subroutine cPi_func(me,ip,dp,sp,val,ierr)
10481049

10491050
implicit none
10501051

@@ -1056,17 +1057,21 @@ subroutine ctest0_func(me,ip,dp,sp,val,ierr)
10561057
integer,intent(out) :: ierr !! error flag
10571058

10581059
sp = sp + 1
1059-
me%stack(sp) = 15.0_wp
1060+
me%stack(sp) = pi
10601061
ierr = 0
10611062

1062-
end subroutine ctest0_func
1063+
end subroutine cPi_func
10631064
!******************************************************************
10641065

10651066
!******************************************************************
10661067
!>
1067-
! Test function with three arguments.
1068+
! If function with three arguments.
1069+
!
1070+
! `If(expression, value is true, value if false)`
1071+
!
1072+
! Where: 0 is false and /=0 is true.
10681073

1069-
subroutine ctest3_func(me,ip,dp,sp,val,ierr)
1074+
subroutine cif_func(me,ip,dp,sp,val,ierr)
10701075

10711076
implicit none
10721077

@@ -1077,11 +1082,16 @@ subroutine ctest3_func(me,ip,dp,sp,val,ierr)
10771082
real(wp),dimension(:),intent(in) :: val !! variable values
10781083
integer,intent(out) :: ierr !! error flag
10791084

1080-
me%stack(sp-2) = me%stack(sp-2) + me%stack(sp-1) + me%stack(sp)
1085+
if (me%stack(sp-2) /= zero) then ! true
1086+
me%stack(sp-2) = me%stack(sp-1)
1087+
else ! false
1088+
me%stack(sp-2) = me%stack(sp)
1089+
end if
1090+
10811091
sp = sp - 2
10821092
ierr = 0
10831093

1084-
end subroutine ctest3_func
1094+
end subroutine cif_func
10851095
!******************************************************************
10861096

10871097
!******************************************************************
@@ -1136,9 +1146,9 @@ subroutine find_arg_positions(paren_start, func, num_args, arg_pos, ierr, err_po
11361146
integer :: cur_pos, & !! The current position in `func` being processed.
11371147
func_len, & !! The length of `func`.
11381148
open_parens, & !! The number of open parentheses.
1139-
arg_len, & !! The length of an argument.
1149+
arg_len, & !! The length of an argument.
11401150
iarg !! Argument index.
1141-
1151+
11421152
! Initialize outputs.
11431153
num_args = 1
11441154
arg_pos = 0
@@ -1147,14 +1157,14 @@ subroutine find_arg_positions(paren_start, func, num_args, arg_pos, ierr, err_po
11471157

11481158
func_len = len_trim(func)
11491159
open_parens = 1
1150-
1160+
11511161
cur_pos = paren_start + 1
11521162
func_len = len_trim(func)
11531163

11541164
! Step through the function string until we find the function's closing parenthesis.
11551165
! Every time we find a comma character at the same parentheses level as the function's
1156-
! opening parenthesis, increment the number of arguments and record the previous
1157-
! argument's last character.
1166+
! opening parenthesis, increment the number of arguments and record the previous
1167+
! argument's last character.
11581168
do while (open_parens > 0)
11591169
if (cur_pos > func_len) then
11601170
! The function did not have a closing parenthesis.
@@ -1176,7 +1186,7 @@ subroutine find_arg_positions(paren_start, func, num_args, arg_pos, ierr, err_po
11761186
end if
11771187

11781188
open_parens = open_parens - 1
1179-
1189+
11801190
! We have arrived at the function's closing parenthesis.
11811191
if (open_parens == 0) arg_pos(num_args) = cur_pos - 1
11821192

@@ -1203,9 +1213,9 @@ subroutine find_arg_positions(paren_start, func, num_args, arg_pos, ierr, err_po
12031213
do iarg = 1, num_args
12041214
if (iarg == 1) then
12051215
arg_len = arg_pos(iarg) - paren_start
1206-
else
1216+
else
12071217
arg_len = arg_pos(iarg) - arg_pos(iarg - 1) - 1
1208-
endif
1218+
endif
12091219

12101220
if (arg_len == 0) then
12111221
if (present(ierr)) ierr = empty_arg
@@ -1215,7 +1225,7 @@ subroutine find_arg_positions(paren_start, func, num_args, arg_pos, ierr, err_po
12151225
end do
12161226

12171227
end subroutine find_arg_positions
1218-
1228+
!*******************************************************************************
12191229

12201230
!*******************************************************************************
12211231
!>
@@ -1254,7 +1264,7 @@ recursive subroutine check_syntax (me,func,funcstr,var,ipos)
12541264
if (c == '(') then
12551265
parcnt = parcnt + 1
12561266
elseif (c == ')') then
1257-
parcnt = parcnt - 1
1267+
parcnt = parcnt - 1
12581268
end if
12591269

12601270
if (parcnt < 0) then
@@ -1306,25 +1316,25 @@ recursive subroutine check_syntax (me,func,funcstr,var,ipos)
13061316
call me%add_error(j, ipos, funcstr, 'Missing opening parenthesis')
13071317
return
13081318
end if
1309-
1319+
13101320
! Find the number of function arguments and argument substring positions
13111321
! in `func`.
13121322
call find_arg_positions(j, func, num_args, arg_pos, ierr, err_pos)
13131323
if (ierr /= 0) then
13141324
select case (ierr)
1315-
case (1); call me%add_error(err_pos, ipos, funcstr, 'Missing function closing parenthesis')
1325+
case (1); call me%add_error(err_pos, ipos, funcstr, 'Missing function closing parenthesis')
13161326
case (2); call me%add_error(err_pos, ipos, funcstr, 'Function has too many arguments')
13171327
case (3); call me%add_error(err_pos, ipos, funcstr, 'Function has an empty argument')
13181328
case default; call me%add_error(err_pos, ipos, funcstr, 'Unknown find argument position error')
13191329
end select
13201330
return
13211331
end if
13221332

1323-
! Verify that the number of function arguments present is consistent
1333+
! Verify that the number of function arguments present is consistent
13241334
! with the specified function.
13251335
if (num_args < required_args(n)) then
13261336
call me%add_error(j, ipos, funcstr, 'Missing required function argument')
1327-
return
1337+
return
13281338
elseif (num_args > required_args(n) + optional_args(n)) then
13291339
call me%add_error(j, ipos, funcstr, 'Too many function arguments')
13301340
return
@@ -1336,7 +1346,7 @@ recursive subroutine check_syntax (me,func,funcstr,var,ipos)
13361346
else
13371347
do iarg = 1, num_args
13381348
if (iarg == 1) then
1339-
arg_start = j + 1
1349+
arg_start = j + 1
13401350
else
13411351
arg_start = arg_pos(iarg-1) + 2
13421352
endif
@@ -1346,7 +1356,7 @@ recursive subroutine check_syntax (me,func,funcstr,var,ipos)
13461356

13471357
call me%check_syntax(func(arg_start:arg_end), funcstr, var, func_arg_ipos)
13481358
if (me%error()) return
1349-
end do
1359+
end do
13501360

13511361
j = arg_pos(num_args) + 2
13521362
endif
@@ -1518,7 +1528,7 @@ function mathfunction_index (str) result (n)
15181528
character (len=len(functions)) :: fun
15191529

15201530
n = 0
1521-
do j=cAbs,cTest3 ! check all math functions
1531+
do j=cAbs,cIf ! check all math functions
15221532
k = min(len_trim(functions(j)), len(str))
15231533
call to_lowercase (str(1:k), fun)
15241534
if (fun == functions(j)) then ! compare lower case letters
@@ -1724,8 +1734,8 @@ subroutine add_compiled_byte (me, b, num_args)
17241734
case (1); me%bytecode_ops(me%bytecodesize)%f => catan_func
17251735
case (2); me%bytecode_ops(me%bytecodesize)%f => catan2_func
17261736
end select
1727-
case (cTest0); me%bytecode_ops(me%bytecodesize)%f => ctest0_func
1728-
case (cTest3); me%bytecode_ops(me%bytecodesize)%f => ctest3_func
1737+
case (cPi); me%bytecode_ops(me%bytecodesize)%f => cPi_func
1738+
case (cIf); me%bytecode_ops(me%bytecodesize)%f => cif_func
17291739
case default; me%bytecode_ops(me%bytecodesize)%f => cdefault_func
17301740
end select
17311741

@@ -1749,7 +1759,7 @@ function mathitem_index (me, f, var) result (n)
17491759
integer :: n !! byte value of math item
17501760

17511761
n = 0
1752-
if (len(f)==0) return ! error condition
1762+
if (len(f)==0) return ! error condition
17531763

17541764
if (scan(f(1:1),'0123456789.') > 0) then ! check for begin of a number
17551765
me%immedsize = me%immedsize + 1
@@ -1845,7 +1855,7 @@ recursive subroutine compile_substr (me, f, b, e, var)
18451855
end do
18461856
else
18471857
me%stackptr = me%stackptr + 1
1848-
if (me%stackptr > me%stacksize) me%stacksize = me%stacksize + 1
1858+
if (me%stackptr > me%stacksize) me%stacksize = me%stacksize + 1
18491859
end if
18501860

18511861
call add_compiled_byte (me, n, num_args)
@@ -1877,7 +1887,7 @@ recursive subroutine compile_substr (me, f, b, e, var)
18771887
end do
18781888
else
18791889
me%stackptr = me%stackptr + 1
1880-
if (me%stackptr > me%stacksize) me%stacksize = me%stacksize + 1
1890+
if (me%stackptr > me%stacksize) me%stacksize = me%stacksize + 1
18811891
end if
18821892

18831893
call add_compiled_byte (me, n, num_args)

0 commit comments

Comments
 (0)