subroutine apply_command(command, ok)
use, intrinsic :: ieee_arithmetic
implicit none
character(*), intent(in) :: command
logical, intent(out) :: ok
real(8) :: r, im, ang
complex(8) :: u, z
real(8), allocatable :: tmp_seq(:)
type(rpn_t) :: us, zs
logical :: is_cart
integer :: m, idx
character(len=1) :: comma
character(5), parameter :: lang(2) = ['POINT','COMMA']
ok = .true.
if (len_trim(command) == 0) then
return
end if
if (verbosity > 0) then
write(*,'(a)') 'Applying: '//command
end if
if (in_sequence == 1) then
if (command == '}') then
in_sequence = 2
complex_mode = tmp_cmode
call calculate_stats
else
! All elements must be the same so either all x or all x,y
idx = index(command,',')
if (n_seq == 0) then
seq_is_x = (idx == 0)
end if
if (seq_is_x .neqv. (idx == 0)) then
goto 901
end if
if (seq_is_x) then
read(command,*,err=901) r
im = 0
else
read(command(1:idx-1),*,err=901) r
read(command(idx+1:len(command)),*,err=901) im
end if
! Initial allocation
if (n_seq == 0 .and. .not. allocated(x_seq)) then
allocate(x_seq(10))
if (.not. seq_is_x) then
allocate(y_seq(10))
end if
end if
if (n_seq < size(x_seq)) then
n_seq = n_seq + 1
else
! Expand array
allocate(tmp_seq(n_seq + 10))
tmp_seq(1:n_seq) = x_seq
call move_alloc(tmp_seq, x_seq)
if (.not. seq_is_x) then
allocate(tmp_seq(n_seq + 10))
tmp_seq(1:n_seq) = y_seq
call move_alloc(tmp_seq, y_seq)
end if
end if
x_seq(n_seq) = r
if (.not. seq_is_x) then
y_seq(n_seq) = im
end if
if (verbosity > 0) then
print *,x_seq(1:n_seq)
end if
end if
return
end if
select case(command)
case('q','quit')
ok = .false.
return
case('=')
ok = .false.
return
case('{')
! Start sequence
in_sequence = 1
n_seq = 0
tmp_cmode = complex_mode
complex_mode = .false.
call stats%clear()
case('--')
call invoke_unary(chs_fr)
case('^')
call stack%push(stack%peek(1))
case('+')
call invoke_binary(add_fr)
case('-')
call invoke_binary(subtract_fr)
case('*')
call invoke_binary(multiply_fr)
case('/')
call invoke_binary(divide_fr)
case('^x')
call invoke_binary(power_fr)
case('^/x')
! Only raising to a real power is supported
zs = stack%peek(1)
if (zs%is_real()) then
call invoke_binary(root_fr)
else
goto 901
end if
case('>')
call invoke_unary(next_root_fr)
case('<')
call invoke_unary(previous_root_fr)
case('%')
call invoke_binary(percent_fr)
case('xy','XY')
call stack%swap
case('R')
call stack%rotate_down
case('r')
call stack%rotate_up
case('CLA','cla')
call stack%clear
mem = rpn_t()
call stats%clear
case('CL','cl')
call stack%clear
case('CLX','clx')
call stack%set(rpn_t())
case('_')
if (complex_mode) then
call invoke_unary(conj_fr)
endif
case('len','||')
if (complex_mode) then
call invoke_unary(len_fr)
! Length is always reported as (x,0) and marked is_cartesian
zs = stack%peek(1)
call zs%set_value(is_cartesian=.true.)
call stack%set(zs,1)
else
zs = stack%peek(1)
z = zs%get_value()
us = stack%peek(2)
u = us%get_value()
call zs%set_value(cmplx(hypot(z%re,u%re),0,8))
call stack%set(zs)
end if
case('split')
if (.not. complex_mode) then
zs = stack%pop()
x = zs%get_value()
if (x > 0) then
r = floor(x)
else
r = ceiling(x)
end if
im = x - r
call stack%push(im)
call stack%push(r)
end if
case('int')
if (.not. complex_mode) then
zs = stack%peek(1)
x = zs%get_value()
if (x > 0) then
r = floor(x)
else
r = ceiling(x)
end if
call zs%set_value(cmplx(r,0,8))
call stack%set(zs,1)
end if
case('nint')
if (.not. complex_mode) then
zs = stack%peek(1)
x = zs%get_value()
r = nint(x)
if (mod(r,2.0d0) == 1) then
r = r - 1
end if
call zs%set_value(cmplx(r,0,8))
call stack%set(zs,1)
end if
case('rem')
if (.not. complex_mode) then
zs = stack%peek(1)
x = zs%get_value()
if (x > 0) then
r = floor(x)
else
r = ceiling(x)
end if
im = x - r
call zs%set_value(cmplx(im,0,8))
call stack%set(zs,1)
end if
case('drop')
zs = stack%pop()
case('ri')
! Swap real and imaginary parts
if (complex_mode) then
call invoke_unary(swap_real_imaginary_fr)
end if
case('to_pol')
! Convert x + iy to r + i theta
if (complex_mode) then
zs = stack%peek(1)
call stack%set(to_polar(zs))
end if
case('to_cart')
! Convert (r,theta) to (x,y)
if (complex_mode) then
zs = stack%peek(1)
call stack%set(to_cartesian(zs))
end if
case('1/')
call invoke_unary(reciprocal_fr)
case('^2','sq')
call invoke_unary(power_2_fr)
case('^/2','sqrt')
call invoke_unary(sqrt_fr)
case('^3','cb')
call invoke_unary(power_3_fr)
case('^/3','cbrt')
call invoke_unary(cbrt_fr)
case('^*2','alog2')
call invoke_unary(exp_2_fr)
case('^*10','alog10')
call invoke_unary(exp_10_fr)
case('exp','alog')
call invoke_unary(exp_e_fr)
case('ln')
call invoke_unary(ln_fr)
case('log2')
call invoke_unary(log2_fr)
case('lg')
call invoke_unary(lg_fr)
case('sinh')
call invoke_unary(hsine_fr)
case('cosh')
call invoke_unary(hcosine_fr)
case('tanh')
call invoke_unary(htangent_fr)
case('sin')
call invoke_unary(sine_fr)
case('cos')
call invoke_unary(cosine_fr)
case('tan')
call invoke_unary(tangent_fr)
case('asin')
call invoke_unary(asine_fr)
case('asinh')
call invoke_unary(ahsine_fr)
case('acos')
call invoke_unary(acosine_fr)
case('acosh')
call invoke_unary(ahcosine_fr)
case('atan')
call invoke_unary(atangent_fr)
case('atanh')
call invoke_unary(ahtangent_fr)
case('atan2')
call invoke_binary(atangent2_fr)
case('gamma')
call invoke_unary(gamma_fr)
case('!')
zs = stack%peek(1)
if (zs%is_positive_real()) then
call invoke_unary(fact_fr)
else
goto 901
end if
case('ncr')
zs = stack%peek(1)
us = stack%peek(2)
if (zs%is_positive_real() .and. us%is_positive_real()) then
call invoke_binary(ncr_fr)
else
goto 901
end if
case('npr')
zs = stack%peek(1)
us = stack%peek(2)
if (zs%is_positive_real() .and. us%is_positive_real()) then
call invoke_binary(npr_fr)
else
goto 901
end if
case('m0+','m1+','m2+','m3+','m4+','m5+','m6+','m7+','m8+','m9+')
read(command(2:2),'(i1)',err=901) m
mem(m) = mem(m) + stack%peek(1)
case('m0-','m1-','m2-','m3-','m4-','m5-','m6-','m7-','m8-','m9-')
read(command(2:2),'(i1)',err=901) m
mem(m) = mem(m) - stack%peek(1)
case('m0*','m1*','m2*','m3*','m4*','m5*','m6*','m7*','m8*','m9*')
read(command(2:2),'(i1)',err=901) m
mem(m) = mem(m) * stack%peek(1)
case('m0/','m1/','m2/','m3/','m4/','m5/','m6/','m7/','m8/','m9/')
read(command(2:2),'(i1)',err=901) m
mem(m) = mem(m) / stack%peek(1)
case('st0','st1','st2','st3','st4','st5','st6','st7','st8','st9')
read(command(3:3),'(i1)',err=901) m
mem(m) = stack%peek(1)
case('sw0','sw1','sw2','sw3','sw4','sw5','sw6','sw7','sw8','sw9')
read(command(3:3),'(i1)',err=901) m
zs = stack%peek(1)
call stack%set(mem(m))
mem(m) = zs
case('rc0','rc1','rc2','rc3','rc4','rc5','rc6','rc7','rc8','rc9')
read(command(3:3),'(i1)',err=901) m
call stack%push(mem(m))
case('cl0','cl1','cl2','cl3','cl4','cl5','cl6','cl7','cl8','cl9')
read(command(3:3),'(i1)',err=901) m
mem(m) = rpn_t()
case('msh')
write(6,'(i3,a,dt)') (i,': ',mem(i),i=0,size(mem)-1)
case('fix0','fix1','fix2','fix3','fix4','fix5','fix6','fix7','fix8','fix9')
read(command(4:4),'(i1)') m
call set_places(m)
case('DEG','deg','DEGREES','degrees')
call toggle_degrees_mode(.true.)
case('RAD','rad','RADIANS','radians')
call toggle_degrees_mode(.false.)
case('mC','COMPLEX','complex')
complex_mode = .true.
case('mR','REAL','real')
complex_mode = .false.
case('mV','VERBOSE','verbose')
veMode = .true.
case('mT','TERSE','terse')
veMode = .false.
case('?')
write(6,advance='no',fmt='(a)') 'Status: '
write(6,advance='no',fmt='(2a)') merge('degrees','radians',degrees_mode),' ; '
write(6,advance='no',fmt='(a,i0)') 'dp = ',get_places()
if (complex_mode) then
write(6,advance='no',fmt='(a)') ' ; mode = complex'
else
write(6,advance='no',fmt='(a)') ' ; mode = real'
end if
write(6,advance='no',fmt='(a,i0)') ' ; stack size = ',stack%get_size()
write(6,'(a/)') ''
case('help','h')
call help
case default
! Process constants first
block
integer :: lc, is_integer,split_idx,end_idx
character(len=:), allocatable :: re_comp, im_comp
lc = len_trim(command)
is_integer = (index(command,'.') == 0)
if (complex_mode) then
if (command(1:1) == '(') then
split_idx = index(command,',')
end_idx = index(command,')')
re_comp = command(2:split_idx-1)
im_comp = command(split_idx+1:end_idx-1)
if (constants%contains(re_comp)) then
z%re = constants%get_value(re_comp)
else
read(re_comp,*,err=901,end=901) z%re
end if
if (constants%contains(im_comp)) then
z%im = constants%get_value(im_comp)
else
read(im_comp,*,err=901,end=901) z%im
end if
if (command(lc:lc) == 'p') then
call stack%push(z,.false.)
else
call stack%push(z)
end if
else
if (constants%contains(command)) then
x = constants%get_value(command)
else
read(command,*,err=901,end=901) x
end if
call stack%push(cmplx(x,0.0d0,8))
end if
else
if (constants%contains(command)) then
x = constants%get_value(command)
else if (stats%contains(command)) then
x = stats%get_value(command)
else
read(command,*,err=901,end=901) x
end if
call stack%push(cmplx(x,0.0d0,8))
end if
end block
end select
return
901 continue
write(6,'(a)') command//' ???'
return
end subroutine apply_command