c   crc's _ _
c        (_) | ___
c        | | |/ _ \  a tiny virtual computer
c        | | | (_) | 64kw RAM, 32-bit, Dual Stack, MISC
c        |_|_|\___/  ilo.f (c) charles childers
c     ilo.f -- ilo virtual machine for gfortran
c     Fortran 77 style, with GNU extensions for command line
c     args, little-endian direct binary files, and single
c     character I/O.

      program ilo
      implicit none
      integer ip, sp, rp, ds, as, m
      integer halted
      character*256 blocks, rom
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      common /state/ halted
      common /files/ blocks, rom
      integer iargc

      blocks = 'ilo.blocks'
      rom = 'ilo.rom'
      if (iargc() .ge. 1) call getarg(1, blocks)
      if (iargc() .ge. 2) call getarg(2, rom)

      call load_image
      call execute
      call dump_stack
      end

      subroutine push(v)
      implicit none
      integer v
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      sp = sp + 1
      ds(sp) = v
      return
      end

      integer function pop()
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      pop = ds(sp)
      sp = sp - 1
      return
      end

      subroutine load_image
      implicit none
      integer ip, sp, rp, ds, as, m
      integer halted
      character*256 blocks, rom
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      common /state/ halted
      common /files/ blocks, rom
      integer i

      halted = 0
      do 5 i = 0, 131071
         m(i) = 0
    5 continue
      do 6 i = 0, 32
         ds(i) = 0
    6 continue
      do 7 i = 0, 256
         as(i) = 0
    7 continue
      open(10, file=rom, access='direct', form='unformatted',
     &     recl=4, status='old', convert='little_endian', err=20)
      do 10 i = 0, 65535
         read(10, rec=i+1, err=15) m(i)
   10 continue
   15 close(10)
      ip = 0
      sp = 0
      rp = 0
   20 return
      end

      subroutine save_image
      implicit none
      integer ip, sp, rp, ds, as, m
      character*256 blocks, rom
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      common /files/ blocks, rom
      integer i

      open(10, file=rom, access='direct', form='unformatted',
     &     recl=4, status='unknown', convert='little_endian', err=20)
      do 10 i = 0, 65535
         write(10, rec=i+1, err=15) m(i)
   10 continue
   15 close(10)
   20 return
      end

      subroutine read_block
      implicit none
      integer ip, sp, rp, ds, as, m
      character*256 blocks, rom
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      common /files/ blocks, rom
      integer block, buffer, i, pop

      buffer = pop()
      block = pop()
      open(11, file=blocks, access='direct', form='unformatted',
     &     recl=4, status='old', convert='little_endian', err=30)
      do 10 i = 0, 1023
         read(11, rec=block*1024+i+1, err=20) m(buffer+i)
   10 continue
   20 close(11)
   30 return
      end

      subroutine write_block
      implicit none
      integer ip, sp, rp, ds, as, m
      character*256 blocks, rom
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      common /files/ blocks, rom
      integer block, buffer, i, pop

      buffer = pop()
      block = pop()
      open(11, file=blocks, access='direct', form='unformatted',
     &     recl=4, status='old', convert='little_endian', err=30)
      do 10 i = 0, 1023
         write(11, rec=block*1024+i+1, err=20) m(buffer+i)
   10 continue
   20 close(11)
   30 return
      end

      subroutine process(o)
      implicit none
      integer o

      if (o .eq. 0) then
         return
      else if (o .eq. 1) then
         call li
      else if (o .eq. 2) then
         call du
      else if (o .eq. 3) then
         call dr
      else if (o .eq. 4) then
         call sw
      else if (o .eq. 5) then
         call pu
      else if (o .eq. 6) then
         call po
      else if (o .eq. 7) then
         call ju
      else if (o .eq. 8) then
         call ca
      else if (o .eq. 9) then
         call cc
      else if (o .eq. 10) then
         call cj
      else if (o .eq. 11) then
         call re
      else if (o .eq. 12) then
         call eq
      else if (o .eq. 13) then
         call ne
      else if (o .eq. 14) then
         call lt
      else if (o .eq. 15) then
         call gt
      else if (o .eq. 16) then
         call fe
      else if (o .eq. 17) then
         call st
      else if (o .eq. 18) then
         call ad
      else if (o .eq. 19) then
         call su
      else if (o .eq. 20) then
         call mu
      else if (o .eq. 21) then
         call di
      else if (o .eq. 22) then
         call an
      else if (o .eq. 23) then
         call or
      else if (o .eq. 24) then
         call xo
      else if (o .eq. 25) then
         call sl
      else if (o .eq. 26) then
         call sr
      else if (o .eq. 27) then
         call cp
      else if (o .eq. 28) then
         call cy
      else if (o .eq. 29) then
         call io
      endif
      return
      end

      subroutine process_bundle(o)
      implicit none
      integer o
      integer halted
      common /state/ halted
      call process(iand(o, 255))
      if (halted .ne. 0) return
      call process(iand(ishft(o, -8), 255))
      if (halted .ne. 0) return
      call process(iand(ishft(o, -16), 255))
      if (halted .ne. 0) return
      call process(iand(ishft(o, -24), 255))
      return
      end

      subroutine execute
      implicit none
      integer ip, sp, rp, ds, as, m
      integer halted
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      common /state/ halted
   10 if (ip .lt. 65536 .and. halted .eq. 0) then
         call process_bundle(m(ip))
         ip = ip + 1
         goto 10
      endif
      return
      end

      subroutine li
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ip = ip + 1
      call push(m(ip))
      return
      end

      subroutine du
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      call push(ds(sp))
      return
      end

      subroutine dr
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ds(sp) = 0
      sp = sp - 1
      return
      end

      subroutine sw
      implicit none
      integer ip, sp, rp, ds, as, m
      integer a
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      a = ds(sp)
      ds(sp) = ds(sp-1)
      ds(sp-1) = a
      return
      end

      subroutine pu
      implicit none
      integer ip, sp, rp, ds, as, m
      integer pop
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      rp = rp + 1
      as(rp) = pop()
      return
      end

      subroutine po
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      call push(as(rp))
      rp = rp - 1
      return
      end

      subroutine ju
      implicit none
      integer ip, sp, rp, ds, as, m
      integer pop
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ip = pop() - 1
      return
      end

      subroutine ca
      implicit none
      integer ip, sp, rp, ds, as, m
      integer pop
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      rp = rp + 1
      as(rp) = ip
      ip = pop() - 1
      return
      end

      subroutine cc
      implicit none
      integer ip, sp, rp, ds, as, m
      integer a, pop
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      a = pop()
      if (pop() .ne. 0) then
         rp = rp + 1
         as(rp) = ip
         ip = a - 1
      endif
      return
      end

      subroutine cj
      implicit none
      integer ip, sp, rp, ds, as, m
      integer a, pop
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      a = pop()
      if (pop() .ne. 0) ip = a - 1
      return
      end

      subroutine re
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ip = as(rp)
      rp = rp - 1
      return
      end

      subroutine eq
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      if (ds(sp-1) .eq. ds(sp)) then
         ds(sp-1) = -1
      else
         ds(sp-1) = 0
      endif
      sp = sp - 1
      return
      end

      subroutine ne
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      if (ds(sp-1) .ne. ds(sp)) then
         ds(sp-1) = -1
      else
         ds(sp-1) = 0
      endif
      sp = sp - 1
      return
      end

      subroutine lt
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      if (ds(sp-1) .lt. ds(sp)) then
         ds(sp-1) = -1
      else
         ds(sp-1) = 0
      endif
      sp = sp - 1
      return
      end

      subroutine gt
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      if (ds(sp-1) .gt. ds(sp)) then
         ds(sp-1) = -1
      else
         ds(sp-1) = 0
      endif
      sp = sp - 1
      return
      end

      subroutine fe
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ds(sp) = m(ds(sp))
      return
      end

      subroutine st
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      m(ds(sp)) = ds(sp-1)
      sp = sp - 2
      return
      end

      subroutine ad
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ds(sp-1) = ds(sp-1) + ds(sp)
      sp = sp - 1
      return
      end

      subroutine su
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ds(sp-1) = ds(sp-1) - ds(sp)
      sp = sp - 1
      return
      end

      subroutine mu
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ds(sp-1) = ds(sp-1) * ds(sp)
      sp = sp - 1
      return
      end

      subroutine di
      implicit none
      integer ip, sp, rp, ds, as, m
      integer a, b
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      a = ds(sp)
      b = ds(sp-1)
      ds(sp) = b / a
      ds(sp-1) = mod(b, a)
      if (b .ge. 0 .and. ds(sp-1) .lt. 0) then
         ds(sp) = ds(sp) + 1
         ds(sp-1) = ds(sp-1) - b
      endif
      return
      end

      subroutine an
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ds(sp-1) = iand(ds(sp), ds(sp-1))
      sp = sp - 1
      return
      end

      subroutine or
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ds(sp-1) = ior(ds(sp), ds(sp-1))
      sp = sp - 1
      return
      end

      subroutine xo
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ds(sp-1) = ieor(ds(sp), ds(sp-1))
      sp = sp - 1
      return
      end

      subroutine sl
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ds(sp-1) = ishft(ds(sp-1), ds(sp))
      sp = sp - 1
      return
      end

      subroutine sr
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ds(sp-1) = shifta(ds(sp-1), ds(sp))
      sp = sp - 1
      return
      end

      subroutine cp
      implicit none
      integer ip, sp, rp, ds, as, m
      integer l, d, s, pop
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      l = pop()
      d = pop()
      s = ds(sp)
      ds(sp) = -1
   10 if (l .gt. 0) then
         if (m(d) .ne. m(s)) ds(sp) = 0
         l = l - 1
         s = s + 1
         d = d + 1
         goto 10
      endif
      return
      end

      subroutine cy
      implicit none
      integer ip, sp, rp, ds, as, m
      integer l, d, s, pop
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      l = pop()
      d = pop()
      s = pop()
   10 if (l .gt. 0) then
         m(d) = m(s)
         l = l - 1
         s = s + 1
         d = d + 1
         goto 10
      endif
      return
      end

      subroutine io
      implicit none
      integer op, pop
      op = pop()
      if (op .eq. 0) then
         call io_write_char
      else if (op .eq. 1) then
         call io_read_char
      else if (op .eq. 2) then
         call read_block
      else if (op .eq. 3) then
         call write_block
      else if (op .eq. 4) then
         call save_image
      else if (op .eq. 5) then
         call load_image
         call set_ip_minus_one
      else if (op .eq. 6) then
         call set_ip_done
      else if (op .eq. 7) then
         call push_depths
      endif
      return
      end

      subroutine io_write_char
      implicit none
      integer c, pop, status
      character*1 ch
      c = pop()
      ch = char(iand(c, 255))
      call fputc(6, ch, status)
      return
      end

      subroutine io_read_char
      implicit none
      integer ip, sp, rp, ds, as, m
      integer halted
      integer status
      character*1 ch
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      common /state/ halted
      call fgetc(5, ch, status)
      if (status .eq. 0) then
         call push(ichar(ch))
      else
         ip = 65536
         halted = 1
      endif
      return
      end

      subroutine set_ip_minus_one
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      ip = -1
      return
      end

      subroutine set_ip_done
      implicit none
      integer ip, sp, rp, ds, as, m
      integer halted
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      common /state/ halted
      ip = 65536
      halted = 1
      return
      end

      subroutine push_depths
      implicit none
      integer ip, sp, rp, ds, as, m
      integer s
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
      s = sp
      call push(s)
      call push(rp)
      return
      end

      subroutine dump_stack
      implicit none
      integer ip, sp, rp, ds, as, m
      common /vm/ ip, sp, rp, ds(0:32), as(0:256), m(0:131071)
   10 if (sp .gt. 0) then
         write(*, 100) ds(sp)
         sp = sp - 1
         goto 10
      endif
      write(*,*)
  100 format(1x, i0, $)
      return
      end