module Exec

  implicit NONE

  private

  public :: Execute

  integer, parameter, public :: Why_Single=0, Why_Halt=1, Why_Pause=2, &
    & Why_Bad=3

contains

  subroutine Execute ( CC, Single_FP, Single_Step, Why_Return )

    use Memory
    use Output_m, only: Places, Position, TabulatingNumber, TypeFixed, &
      & TypeFloat
    use Paper_Tape

    integer, intent(inout) :: CC       ! Command counter 0700..1899 if
                                       ! Single_FP else 0900-1899
    logical, intent(in) :: Single_FP   ! Single precision FP
    logical, intent(in) :: Single_Step ! Execute one instruction and return
    integer, intent(out) :: Why_Return

    type Index_t
      integer :: WordBase
      integer :: WordDifference
      integer :: WordLimit
      integer :: ChannelBase
      integer :: ChannelDifference
      integer :: ChannelLimit
    end type Index_t

    type(index_t) :: Index(0:9) = index_t(0,0,0,0,0,0)

    integer :: CC_Channel, CC_Word, CC_low
    integer :: Addr_Channel, Addr_Word
    integer :: Top_Word ! 99 if not I/O, else 100
    integer :: IOSTAT

    character(7) :: Text ! For dumping instruction

    logical :: Error
    logical :: My_Single_Step

    real, save, target :: Single_Acum = 0             ! 2101
    real, pointer :: Single_Word
    real :: Single_deg                                ! degrees to radians
    double precision, save, target :: Double_Acum = 0 ! 2100
    double precision, pointer :: Double_Word
    double precision :: Double_deg                    ! degrees to radians

    integer, save :: Place_1, Place_2 ! for Mark Place instructions

1   format ( a, i4.4, a )

    my_single_step = single_step
    why_return = why_single

    cc_low = 0900
    if ( single_fp ) cc_low = 0700

    cc = cc - 1

    single_deg = atan(4.0e0) / 45.0e0
    double_deg = atan(4.0d0) / 45.0d0

    what(19,00) = w_instr

    do

      cc = cc + 1
      cc_word = mod(cc,100)
      cc_channel = cc / 100

      ! Is the CC address within range?
      if ( cc < cc_low .or. cc > 1900 ) then
        print 1, 'CC address ', cc, ' out of range'
        return
      end if

      ! Does CC address an instruction?
      if ( what(cc_channel,cc_word) /= w_instr ) then
        print 1, 'Word at CC ', cc, ' is not an instruction'
        return
      end if

      call format_instruction ( instructions(cc_channel,cc_word), text )

      addr_channel = instructions(cc_channel,cc_word)%channel + &
        & index(instructions(cc_channel,cc_word)%index)%channelBase
      addr_word = instructions(cc_channel,cc_word)%word + &
        & index(instructions(cc_channel,cc_word)%index)%wordBase

      top_word = 99
      if ( instructions(cc_channel,cc_word)%command == 39 .or. & ! Punch
         & instructions(cc_channel,cc_word)%command == 55 ) &    ! Read
         & top_word = 100

      if ( addr_channel > 18 .and. addr_channel /= 21 ) then
        print 1, 'Channel out of range in instruction ', cc, ': ' // &
          & trim(text(1:7))
        if ( instructions(cc_channel,cc_word)%index > 0 ) &
          & print 2, index(instructions(cc_channel,cc_word)%index)
2       format ('Index WB ', i2.2, ' WD ', i2.2, ' WL ', i2.2, &
               &     ' CB ', i2.2, ' CD ', i2.2, ' CL ', i2.2)
        return
      end if

      if ( addr_word > top_word .and. &
         & ( addr_channel /= 21 .or. addr_word > 1 ) ) then
        print 1, 'Word overflow in instruction ', cc, ': ' // &
          & trim(text(1:7))
        if ( instructions(cc_channel,cc_word)%index > 0 ) &
          & print 2, index(instructions(cc_channel,cc_word)%index)
        return
      end if

      select case ( instructions(cc_channel,cc_word)%command )
      case ( 08 ) ! perform subroutine
        select case ( subroutines(addr_channel) )
        case ( s_none )
        case ( s_i_o )
          select case ( addr_word )
          case ( 1:7 )
            places = addr_word
          case ( 8 )
            places = 0
          case default
            exit
          end select
        case ( s_sqrt )
          if ( single_fp ) then
            select case ( addr_word )
            case ( e_sqrt )  ! 97  sqrt
              single_acum = sqrt(single_acum)
            case default
              exit
            end select
          else
            select case ( addr_word )
            case ( e_sqrt )  ! 97  sqrt
              double_acum = sqrt(double_acum)
            case default
              exit
            end select
          end if
        case ( s_log )
          if ( single_fp ) then
            select case ( addr_word )
            case ( e_log10 ) ! 71  log 10
              single_acum = log10(single_acum)
            case ( e_log )   ! 17  log e
              single_acum = log(single_acum)
            case ( e_log2 )  ! 8   log 2
              single_acum = log(single_acum) / log(2.0)
            case default
              exit
            end select
          else
            select case ( addr_word )
            case ( e_log10 ) ! 71  log 10
              double_acum = log10(double_acum)
            case ( e_log )   ! 17  log e
              double_acum = log(double_acum)
            case ( e_log2 )  ! 8   log 2
              double_acum = log(double_acum) / log(2.0d0)
            case default
              exit
            end select
          end if
        case ( s_exp )
          if ( single_fp ) then
            select case ( addr_word )
            case ( e_10_x )  ! 72  10**x
              single_acum = 10.0 ** single_acum
            case ( e_e_x )   ! 22  exp
              single_acum = exp(single_acum)
            case ( e_2_x )   ! 08  2**x
              single_acum = 2.0 ** single_acum
            case default
              exit
            end select
          else
            select case ( addr_word )
            case ( e_10_x )  ! 72  10**x
              double_acum = 10.0d0 ** double_acum
            case ( e_e_x )   ! 22  exp
              double_acum = exp(double_acum)
            case ( e_2_x )   ! 08  2**x
              double_acum = 2.0d0 ** double_acum
            case default
              exit
            end select
          end if
        case ( s_trig )
          if ( single_fp ) then
            select case ( addr_word )
            case ( e_sin_r ) ! 42  sin(radians)
              single_acum = sin(single_acum)
            case ( e_sin_d ) ! 39  sin(degrees)
              single_acum = sin(single_deg * single_acum)
            case ( e_cos_r ) ! 26  cos(radians)
              single_acum = cos(single_acum)
            case ( e_cos_d ) ! 23  cos(degrees)
              single_acum = cos(single_acum)
            case default
              exit
            end select
          else
            select case ( addr_word )
            case ( e_sin_r ) ! 42  sin(radians)
              double_acum = sin(double_acum)
            case ( e_sin_d ) ! 39  sin(degrees)
              double_acum = sin(double_deg * double_acum)
            case ( e_cos_r ) ! 26  cos(radians)
              double_acum = cos(double_acum)
            case ( e_cos_d ) ! 23  cos(degrees)
              double_acum = cos(double_acum)
            case default
              exit
            end select
          end if
        case ( s_arctan )
          if ( single_fp ) then
            select case ( addr_word )
            case ( e_atan )  ! 24  atan => radians
              single_acum = atan(single_acum)
            case default
              exit
            end select
          else
            select case ( addr_word )
            case ( e_atan )  ! 24  atan => radians
              double_acum = atan(double_acum)
            case default
              exit
            end select
          end if
        end select
      case ( 16 ) ! return to marked place 1
        cc = place_1
      case ( 18 ) ! return to marked place 2
        cc = place_2
      case ( 20 ) ! transfer if accumulator positive or zero
        if ( single_fp ) then
          if ( single_acum >= 0 ) cc = 100 * addr_channel + addr_word - 1
        else
          if ( double_acum >= 0 ) cc = 100 * addr_channel + addr_word - 1
        end if
      case ( 22 ) ! transfer if accumulator negative
        if ( single_fp ) then
          if ( single_acum < 0 ) cc = 100 * addr_channel + addr_word - 1
        else
          if ( double_acum < 0 ) cc = 100 * addr_channel + addr_word - 1
        end if
      case ( 23 ) ! transfer if accumulator zero
        if ( single_fp ) then
          if ( single_acum == 0 ) cc = 100 * addr_channel + addr_word - 1
        else
          if ( double_acum == 0 ) cc = 100 * addr_channel + addr_word - 1
        end if
      case ( 26 ) ! mark place and transfer 1
        place_1 = cc
        cc = 100 * addr_channel + addr_word - 1
      case ( 28 ) ! mark place and transfer 2
        place_2 = cc
        cc = 100 * addr_channel + addr_word - 1
      case ( 29 ) ! transfer control unconditionally
        cc = 100 * addr_channel + addr_word - 1
      case ( 30 ) ! position typewriter paper
        call position ( addr_channel, addr_word )
      case ( 31 ) ! type tabulating number and tab
        call tabulatingNumber ( 100*addr_channel + addr_word )
      case ( 32 ) ! type floating-point number and tab
        if ( what(addr_channel,addr_word) /= w_data ) then
          print 1, 'Word at ', 100*addr_channel+addr_word, ' is not data'
          exit
        end if
        if ( single_fp ) then
          call typeFloat ( single(addr_channel,addr_word), 1, 0 )
        else
          call typeFloat ( double(addr_channel,addr_word), 1, 0 )
        end if
      case ( 33 ) ! type fixed-point number and tab
        if ( what(addr_channel,addr_word) /= w_data ) then
          print 1, 'Word at ', 100*addr_channel+addr_word, ' is not data'
          exit
        end if
        if ( single_fp ) then
          call typeFixed ( single(addr_channel,addr_word), 1, 0 )
        else
          call typeFixed ( double(addr_channel,addr_word), 1, 0 )
        end if
      case ( 34 ) ! type floating-point number and carriage return
        if ( what(addr_channel,addr_word) /= w_data ) then
          print 1, 'Word at ', 100*addr_channel+addr_word, ' is not data'
          exit
        end if
        if ( single_fp ) then
          call typeFloat ( single(addr_channel,addr_word), 0, 1 )
        else
          call typeFloat ( double(addr_channel,addr_word), 0, 1 )
        end if
      case ( 38 ) ! type fixed-point number and carriage return
        if ( what(addr_channel,addr_word) /= w_data ) then
          print 1, 'Word at ', 100*addr_channel+addr_word, ' is not data'
          exit
        end if
        if ( single_fp ) then
          call typeFixed ( single(addr_channel,addr_word), 0, 1 )
        else
          call typeFixed ( double(addr_channel,addr_word), 0, 1 )
        end if
      case ( 39 ) ! punch paper tape
        if ( addr_channel < cc_low / 100 ) exit
        call write_paper_tape ( addr_channel, addr_word, single_fp )
      case ( 40:45, 46:49, 51, 52 )
        if ( single_fp ) then
          if ( addr_channel == 21 ) then
            single_word => single_acum
          else
            if ( what(addr_channel,addr_word) /= w_data ) then
              print 1, 'Word at ', 100*addr_channel+addr_word, ' is not data'
              exit
            end if
            single_word => single(addr_channel,addr_word)
          end if
          select case ( instructions(cc_channel,cc_word)%command )
          case ( 40 ) ! clear and subtract
            single_acum = -single_word
          case ( 41 ) ! subtract
            single_acum = single_acum - single_word
          case ( 42 ) ! clear and add
            single_acum = single_word
          case ( 43 ) ! add
            single_acum = single_acum + single_word
          case ( 44 ) ! multiply
            single_acum = single_acum * single_word
          case ( 45 ) ! clear and add absolute value
            single_acum = abs(single_word)
          case ( 46 ) ! invalid
          case ( 47 ) ! inverse divide
            single_acum = single_word / single_acum
          case ( 48 ) ! divide
            single_acum = single_acum / single_word
          case ( 49 ) ! store
            single_word = single_acum
            what(addr_channel,addr_word) = w_data
          case ( 51 ) ! permit type in of fixed-point data
            if ( addr_channel < cc_low / 100 ) exit
            do
              print 1, 'Enter fixed-point data for ', addr_channel*100+addr_word
              read ( *, *, iostat=iostat ) single_word
              if ( iostat == 0 ) exit
              print *, 'Error occurred'
            end do
            what(addr_channel,addr_word) = w_data
          case ( 52 ) ! permit type in of floating-point data
            if ( addr_channel < cc_low / 100 ) exit
            do
              print 1, 'Enter fixed-point data for ', addr_channel*100+addr_word
              read ( *, *, iostat=iostat ) single_word
              if ( iostat == 0 ) exit
              print *, 'Error occurred'
            end do
            what(addr_channel,addr_word) = w_data
          end select
        else
          if ( mod(addr_word,2) /= 0 ) then
            print 1, 'Odd data address in instruction ', cc, ': ' // trim(text)
            return
          end if
          if ( addr_channel == 21 ) then
            double_word => double_acum
          else
            if ( what(addr_channel,addr_word) /= w_data .or. &
               & what(addr_channel,addr_word+1) /= w_data ) then
              print 1, 'Double word at ', 100*addr_channel+addr_word, &
                & ' is not data'
              exit
            end if
            double_word => double(addr_channel,addr_word/2)
          end if
          select case ( instructions(cc_channel,cc_word)%command )
          case ( 40 ) ! clear and subtract
            double_acum = -double_word
          case ( 41 ) ! subtract
            double_acum = double_acum - double_word
          case ( 42 ) ! clear and add
            double_acum = double_word
          case ( 43 ) ! add
            double_acum = double_acum + double_word
          case ( 44 ) ! multiply
            double_acum = double_acum * double_word
          case ( 45 ) ! clear and add absolute value
            double_acum = abs(double_word)
          case ( 46 ) ! invalid
          case ( 47 ) ! inverse divide
            double_acum = double_word / double_acum
          case ( 48 ) ! divide
            double_acum = double_acum / double_word
          case ( 49 ) ! store
            double_word = double_acum
            what(addr_channel,addr_word:addr_word+1) = w_data
          case ( 51 ) ! permit type in of fixed-point data
            if ( addr_channel < cc_low / 100 ) exit
            do
              print 1, 'Enter fixed-point data for ', addr_channel*100+addr_word
              read ( *, *, iostat=iostat ) double_word
              if ( iostat == 0 ) exit
              print *, 'Error occurred'
            end do
            what(addr_channel,addr_word) = w_data
          case ( 52 ) ! permit type in of floating-point data
            if ( addr_channel < cc_low / 100 ) exit
            do
              print 1, 'Enter fixed-point data for ', addr_channel*100+addr_word
              read ( *, *, iostat=iostat ) double_word
              if ( iostat == 0 ) exit
              print *, 'Error occurred'
            end do
            what(addr_channel,addr_word) = w_data
          end select
        end if
      case ( 50 ) ! permit command type in
        if ( addr_channel < cc_low / 100 ) exit
        do
          print '(a,i2.2,a,i2.2)', 'Enter command to be stored at ', &
            & addr_channel, ':', addr_word
          read ( *, '(a)' ) text
          call read_instruction ( text, instructions(addr_channel,addr_word), &
            & error )
          if ( error ) then
            print '(a)', 'Invalid instruction'
          else
            what(addr_channel,addr_word) = w_instr
            exit
          end if
        end do
      case ( 55 ) ! read punched paper tape
        if ( addr_channel < cc_low / 100 ) exit
        call read_paper_tape ( addr_channel, addr_word, single_fp, error )
        if ( error ) exit
      case ( 63 ) ! ring bell
        print '(a)', achar(7)
      case ( 67 ) ! halt and permit manual operation
        why_return = why_halt
        return
      case ( 68 ) ! breakpoint halt
        why_return = why_pause
        return
      case ( 69 ) ! compute automatically
        my_single_step = .false.
        cc = 100 * addr_channel + addr_word - 1
      case ( 70 ) ! assign word base
        if ( instructions(cc_channel,cc_word)%index > 0 ) &
          & index(instructions(cc_channel,cc_word)%index)%wordBase = addr_word
      case ( 71 ) ! assign word difference
        if ( instructions(cc_channel,cc_word)%index > 0 ) &
          & index(instructions(cc_channel,cc_word)%index)%wordDifference = addr_word
      case ( 72 ) ! assign word limit
        if ( instructions(cc_channel,cc_word)%index > 0 ) &
          & index(instructions(cc_channel,cc_word)%index)%wordLimit = addr_word
      case ( 73 ) ! assign channel base
        if ( instructions(cc_channel,cc_word)%index > 0 ) &
          & index(instructions(cc_channel,cc_word)%index)%channelBase = addr_channel
      case ( 74 ) ! assign channel difference
        if ( instructions(cc_channel,cc_word)%index > 0 ) &
          & index(instructions(cc_channel,cc_word)%index)%channelDifference = addr_channel
      case ( 75 ) ! assign channel limit
        if ( instructions(cc_channel,cc_word)%index > 0 ) &
          & index(instructions(cc_channel,cc_word)%index)%channelLimit = addr_channel
      case ( 76 ) ! increment word base
        if ( instructions(cc_channel,cc_word)%index > 0 ) then
          index(instructions(cc_channel,cc_word)%index)%wordBase = &
          & index(instructions(cc_channel,cc_word)%index)%wordBase + &
          & index(instructions(cc_channel,cc_word)%index)%wordDifference
          if ( index(instructions(cc_channel,cc_word)%index)%wordBase <= &
             & index(instructions(cc_channel,cc_word)%index)%wordLimit ) &
               & cc = 100 * addr_channel + addr_word - 1
        end if
      case ( 77 ) ! increment channel base
        if ( instructions(cc_channel,cc_word)%index > 0 ) then
          index(instructions(cc_channel,cc_word)%index)%channelBase = &
          & index(instructions(cc_channel,cc_word)%index)%channelBase + &
          & index(instructions(cc_channel,cc_word)%index)%channelDifference
          if ( index(instructions(cc_channel,cc_word)%index)%channelBase <= &
             & index(instructions(cc_channel,cc_word)%index)%channelLimit ) &
               & cc = 100 * addr_channel + addr_word - 1
        end if
      case default
        exit
      end select

      if ( my_single_step ) return

    end do

    print 1, 'Invalid instruction ', cc, ': ' // trim(text)
    why_return = why_bad
    return

  end subroutine Execute

end module Exec
