A virtual machine implements a computer in software.

Task[edit]
Write a virtual machine interpreter. This interpreter should be able to run virtual
assembly language programs created via the task. This is a
byte-coded, 32-bit word stack based virtual machine.

The program should read input from a file and/or stdin, and write output to a file and/or
stdout.

Input format:

Given the following program:

count = 1;
while (count < 10) {
    print("count is: ", count, "\n");
    count = count + 1;
}

The output from the Code generator is a virtual assembly code program:



 Output from gen, input to VM



Datasize: 1 Strings: 2
"count is: "
"\n"
    0 push  1
    5 store [0]
   10 fetch [0]
   15 push  10
   20 lt
   21 jz     (43) 65
   26 push  0
   31 prts
   32 fetch [0]
   37 prti
   38 push  1
   43 prts
   44 fetch [0]
   49 push  1
   54 add
   55 store [0]
   60 jmp    (-51) 10
   65 halt

The first line of the input specifies the datasize required and the number of constant
strings, in the order that they are reference via the code.

The data can be stored in a separate array, or the data can be stored at the beginning of
the stack. Data is addressed starting at 0. If there are 3 variables, the 3rd one if
referenced at address 2.

If there are one or more constant strings, they come next. The code refers to these
strings by their index. The index starts at 0. So if there are 3 strings, and the code
wants to reference the 3rd string, 2 will be used.

Next comes the actual virtual assembly code. The first number is the code address of that
instruction. After that is the instruction mnemonic, followed by optional operands,
depending on the instruction.

Registers:

sp:

   the stack pointer - points to the next top of stack.  The stack is a 32-bit integer
   array.

pc:

   the program counter - points to the current instruction to be performed.  The code is an
   array of bytes.

Data:

   data
   string pool

Instructions:

Each instruction is one byte. The following instructions also have a 32-bit integer
operand:

fetch [index]

where index is an index into the data array.

store [index]

where index is an index into the data array.

push n

where value is a 32-bit integer that will be pushed onto the stack.

jmp (n) addr

where (n) is a 32-bit integer specifying the distance between the current location and the
desired location. addr is an unsigned value of the actual code address.

jz (n) addr

where (n) is a 32-bit integer specifying the distance between the current location and the
desired location. addr is an unsigned value of the actual code address.

The following instructions do not have an operand. They perform their operation directly
against the stack:

For the following instructions, the operation is performed against the top two entries in
the stack:

add
sub
mul
div
mod
lt
gt
le
ge
eq
ne
and
or

For the following instructions, the operation is performed against the top entry in the
stack:

neg
not

Print the word at stack top as a character.

prtc

Print the word at stack top as an integer.

prti

Stack top points to an index into the string pool. Print that entry.

prts

Unconditional stop.

halt

 A simple example virtual machine

def run_vm(data_size)
    int stack[data_size + 1000]
    set stack[0..data_size - 1] to 0
    int pc = 0
    while True:
        op = code[pc]
        pc += 1
 
        if op == FETCH:
            stack.append(stack[bytes_to_int(code[pc:pc+word_size])[0]]);
            pc += word_size
        elif op == STORE:
            stack[bytes_to_int(code[pc:pc+word_size])[0]] = stack.pop();
            pc += word_size
        elif op == PUSH:
            stack.append(bytes_to_int(code[pc:pc+word_size])[0]);
            pc += word_size
        elif op == ADD:   stack[-2] += stack[-1]; stack.pop()
        elif op == SUB:   stack[-2] -= stack[-1]; stack.pop()
        elif op == MUL:   stack[-2] *= stack[-1]; stack.pop()
        elif op == DIV:   stack[-2] /= stack[-1]; stack.pop()
        elif op == MOD:   stack[-2] %= stack[-1]; stack.pop()
        elif op == LT:    stack[-2] = stack[-2] <  stack[-1]; stack.pop()
        elif op == GT:    stack[-2] = stack[-2] >  stack[-1]; stack.pop()
        elif op == LE:    stack[-2] = stack[-2] <= stack[-1]; stack.pop()
        elif op == GE:    stack[-2] = stack[-2] >= stack[-1]; stack.pop()
        elif op == EQ:    stack[-2] = stack[-2] == stack[-1]; stack.pop()
        elif op == NE:    stack[-2] = stack[-2] != stack[-1]; stack.pop()
        elif op == AND:   stack[-2] = stack[-2] and stack[-1]; stack.pop()
        elif op == OR:    stack[-2] = stack[-2] or  stack[-1]; stack.pop()
        elif op == NEG:   stack[-1] = -stack[-1]
        elif op == NOT:   stack[-1] = not stack[-1]
        elif op == JMP:   pc += bytes_to_int(code[pc:pc+word_size])[0]
        elif op == JZ:    if stack.pop() then pc += word_size else pc += bytes_to_int(code[pc:pc+word_size])[0]
        elif op == PRTC:  print stack[-1] as a character; stack.pop()
        elif op == PRTS:  print the constant string referred to by stack[-1]; stack.pop()
        elif op == PRTI:  print stack[-1] as an integer; stack.pop()
        elif op == HALT:  break
 Additional examples
Your solution should pass all the test cases above and the additional tests found Here.

Reference
The C and Python versions can be considered reference implementations.

Related Tasks
 Lexical Analyzer task
 Syntax Analyzer task
 Code Generator task
 AST Interpreter task

######################################################################
#
# The Rosetta Code code virtual machine in Ratfor 77.
#
# The implementation assumes your FORTRAN compiler supports 1-byte
# INTEGER*1 and 4-byte INTEGER*4. Integer storage will be
# native-endian, achieved via EQUIVALENCE. (GNU Fortran and f2c both
# should work.)
#
#
# How to deal with FORTRAN 77 input is a problem. I use formatted
# input, treating each line as an array of type CHARACTER--regrettably
# of no more than some predetermined, finite length. It is a very
# simple method and presents no significant difficulties, aside from
# the restriction on line length of the input.
#
#
# On a POSIX platform, the program can be compiled with f2c and run
# somewhat as follows:
#
#    ratfor77 vm-in-ratfor.r > vm-in-ratfor.f
#    f2c -C -Nc40 vm-in-ratfor.f
#    cc vm-in-ratfor.c -lf2c
#    ./a.out < compiler-tests/primes.vm
#
# With gfortran, a little differently:
#
#    ratfor77 vm-in-ratfor.r > vm-in-ratfor.f
#    gfortran -fcheck=all -std=legacy vm-in-ratfor.f
#    ./a.out < compiler-tests/primes.vm
#
#
# I/O is strictly from default input and to default output, which, on
# POSIX systems, usually correspond respectively to standard input and
# standard output. (I did not wish to have to deal with unit numbers;
# these are now standardized in ISO_FORTRAN_ENV, but that is not
# available in FORTRAN 77.)
#
#---------------------------------------------------------------------
 
# Some parameters you may wish to modify.
 
define(LINESZ, 256)           # Size of an input line.
define(OUTLSZ, 1024)          # Size of an output line.
define(STRNSZ, 4096)          # Size of the string pool.
define(STCKSZ, 4096)          # Size of stacks.
define(MAXVAR, 256)           # Maximum number of variables.
define(MAXSTR, 256)           # Maximum number of strings.
define(CODESZ, 16384)         # Maximum size of a compiled program.
 
define(STRSZ, 2)           # Size of an entry in the VM strings array.
define(STRI,  1)           # Index of the string within strngs.
define(STRN,  2)           # Length of the string.
 
#---------------------------------------------------------------------
 
define(NEWLIN, 10)            # The Unix newline character (ASCII LF).
define(DQUOTE, 34)            # The double quote character.
define(BACKSL, 92)            # The backslash character.
 
#---------------------------------------------------------------------
 
define(OPHALT,  1)
define(OPADD,   2)
define(OPSUB,   3)
define(OPMUL,   4)
define(OPDIV,   5)
define(OPMOD,   6)
define(OPLT,    7)
define(OPGT,    8)
define(OPLE,    9)
define(OPGE,   10)
define(OPEQ,   11)
define(OPNE,   12)
define(OPAND,  13)
define(OPOR,   14)
define(OPNEG,  15)
define(OPNOT,  16)
define(OPPRTC, 17)
define(OPPRTI, 18)
define(OPPRTS, 19)
define(OPFTCH, 20)
define(OPSTOR, 21)
define(OPPUSH, 22)
define(OPJMP,  23)
define(OPJZ,   24)
 
#---------------------------------------------------------------------
 
function issp (c)
 
  # Is a character a space character?
 
  implicit none
 
  character c
  logical issp
 
  integer ic
 
  ic = ichar (c)
  issp = (ic == 32 || (9 <= ic && ic <= 13))
end
 
function isalph (c)
 
  # Is c character code for a letter?
 
  implicit none
 
  integer c
  logical isalph
 
  #
  # The following is correct for ASCII and Unicode, but not for
  # EBCDIC.
  #
  isalph = (ichar ('a') <= c && c <= ichar ('z')) _
             || (ichar ('A') <= c && c <= ichar ('Z'))
end
 
function isdgt (c)
 
  # Is c character code for a digit?
 
  implicit none
 
  integer c
  logical isdgt
 
  isdgt = (ichar ('0') <= c && c <= ichar ('9'))
end
 
function skipsp (str, i, imax)
 
  # Skip past spaces in a string.
 
  implicit none
 
  character str(*)
  integer i
  integer imax
  integer skipsp
 
  logical issp
 
  logical done
 
  skipsp = i
  done = .false.
  while (!done)
    {
      if (imax <= skipsp)
        done = .true.
      else if (!issp (str(skipsp)))
        done = .true.
      else
        skipsp = skipsp + 1
    }
end
 
function skipns (str, i, imax)
 
  # Skip past non-spaces in a string.
 
  implicit none
 
  character str(*)
  integer i
  integer imax
  integer skipns
 
  logical issp
 
  logical done
 
  skipns = i
  done = .false.
  while (!done)
    {
      if (imax <= skipns)
        done = .true.
      else if (issp (str(skipns)))
        done = .true.
      else
        skipns = skipns + 1
    }
end
 
function trimrt (str, n)
 
  # Find the length of a string, if one ignores trailing spaces.
 
  implicit none
 
  character str(*)
  integer n
  integer trimrt
 
  logical issp
 
  logical done
 
  trimrt = n
  done = .false.
  while (!done)
    {
      if (trimrt == 0)
        done = .true.
      else if (!issp (str(trimrt)))
        done = .true.
      else
        trimrt = trimrt - 1
    }
end
 
function skipal (str, i, imax)
 
  # Skip past alphabetic characters in a string.
 
  implicit none
 
  character str(*)
  integer i
  integer imax
  integer skipal
 
  logical isalph
 
  logical done
 
  skipal = i
  done = .false.
  while (!done)
    {
      if (imax <= skipal)
        done = .true.
      else if (!isalph (ichar (str(skipal))))
        done = .true.
      else
        skipal = skipal + 1
    }
end
 
function skipdg (str, i, imax)
 
  # Skip past digits in a string.
 
  implicit none
 
  character str(*)
  integer i
  integer imax
  integer skipdg
 
  logical isdgt
 
  logical done
 
  skipdg = i
  done = .false.
  while (!done)
    {
      if (imax <= skipdg)
        done = .true.
      else if (!isdgt (ichar (str(skipdg))))
        done = .true.
      else
        skipdg = skipdg + 1
    }
end
 
function skipnd (str, i, imax)
 
  # Skip past nondigits in a string.
 
  implicit none
 
  character str(*)
  integer i
  integer imax
  integer skipnd
 
  logical isdgt
 
  logical done
 
  skipnd = i
  done = .false.
  while (!done)
    {
      if (imax <= skipnd)
        done = .true.
      else if (isdgt (ichar (str(skipnd))))
        done = .true.
      else
        skipnd = skipnd + 1
    }
end
 
function skipd1 (str, i, imax)
 
  # Skip past digits and '-' in a string.
 
  implicit none
 
  character str(*)
  integer i
  integer imax
  integer skipd1
 
  logical isdgt
 
  logical done
 
  skipd1 = i
  done = .false.
  while (!done)
    {
      if (imax <= skipd1)
        done = .true.
      else if (!isdgt (ichar (str(skipd1))) && str(skipd1) != '-')
        done = .true.
      else
        skipd1 = skipd1 + 1
    }
end
 
function skipn1 (str, i, imax)
 
  # Skip past nondigits in a string, except '-'.
 
  implicit none
 
  character str(*)
  integer i
  integer imax
  integer skipn1
 
  logical isdgt
 
  logical done
 
  skipn1 = i
  done = .false.
  while (!done)
    {
      if (imax <= skipn1)
        done = .true.
      else if (isdgt (ichar (str(skipn1))) || str(skipn1) == '-')
        done = .true.
      else
        skipn1 = skipn1 + 1
    }
end
 
function tolowr (c)
 
  implicit none
 
  character c
  character tolowr
 
  integer ic
 
  # The following is correct for ASCII, and will work with Unicode
  # code points, but is incorrect for EBCDIC.
 
  ic = ichar (c)
  if (ichar ('A') <= ic && ic <= ichar ('Z'))
    ic = ic - ichar('A') + ichar('a')
  tolowr = char (ic)
end
 
#---------------------------------------------------------------------
 
subroutine addstq (strngs, istrng, src, i0, n0, i, n)
 
  # Add a quoted string to the string pool.
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character src(*)              # Source string.
  integer i0, n0                # Index and length in source string.
  integer i, n                  # Index and length in string pool.
 
  integer j
  logical done
 
1000 format ('attempt to treat an unquoted string as a quoted string')
 
  if (src(i0) != char (DQUOTE) || src(i0 + n0 - 1) != char (DQUOTE))
    {
      write (*, 1000)
      stop
    }
 
  i = istrng
 
  n = 0
  j = i0 + 1
  done = .false.
  while (j != i0 + n0 - 1)
    if (i == STRNSZ)
      {
        write (*, '(''string pool exhausted'')')
        stop
      }
    else if (src(j) == char (BACKSL))
      {
        if (j == i0 + n0 - 1)
          {
            write (*, '(''incorrectly formed quoted string'')')
            stop
          }
        if (src(j + 1) == 'n')
          strngs(istrng) = char (NEWLIN)
        else if (src(j + 1) == char (BACKSL))
          strngs(istrng) = src(j + 1)
        else
          {
            write (*, '(''unrecognized escape sequence'')')
            stop
          }
        istrng = istrng + 1
        n = n + 1
        j = j + 2
      }
    else
      {
        strngs(istrng) = src(j)
        istrng = istrng + 1
        n = n + 1
        j = j + 1
      }
end
 
#---------------------------------------------------------------------
 
subroutine push (stack, sp, i)
 
  implicit none
 
  integer stack(STCKSZ)
  integer sp                    # Stack pointer.
  integer i                     # Value to push.
 
  if (sp == STCKSZ)
    {
      write (*, '(''stack overflow in push'')')
      stop
    }
  stack(sp) = i
  sp = sp + 1
end
 
function pop (stack, sp)
 
  implicit none
 
  integer stack(STCKSZ)
  integer sp                    # Stack pointer.
  integer pop
 
  if (sp == 1)
    {
      write (*, '(''stack underflow in pop'')')
      stop
    }
  sp = sp - 1
  pop = stack(sp)
end
 
function nstack (sp)
 
  implicit none
 
  integer sp                    # Stack pointer.
  integer nstack
 
  nstack = sp - 1               # Current cardinality of the stack.
end
 
#---------------------------------------------------------------------
 
subroutine flushl (outbuf, noutbf)
 
  # Flush a line from the output buffer.
 
  implicit none
 
  character outbuf(OUTLSZ)      # Output line buffer.
  integer noutbf                # Number of characters in outbuf.
 
  character*20 fmt
  integer i
 
  if (noutbf == 0)
    write (*, '()')
  else
    {
      write (fmt, 1000) noutbf
1000  format ('(', I10, 'A)')
      write (*, fmt) (outbuf(i), i = 1, noutbf)
      noutbf = 0
    }
end
 
subroutine wrtchr (outbuf, noutbf, ch)
 
  # Write a character to output.
 
  implicit none
 
  character outbuf(OUTLSZ)      # Output line buffer.
  integer noutbf                # Number of characters in outbuf.
  character ch                  # The character to output.
 
  # This routine silently truncates anything that goes past the buffer
  # boundary.
 
  if (ch == char (NEWLIN))
    call flushl (outbuf, noutbf)
  else if (noutbf < OUTLSZ)
    {
      noutbf = noutbf + 1
      outbuf(noutbf) = ch
    }
end
 
subroutine wrtstr (outbuf, noutbf, str, i, n)
 
  # Write a substring to output.
 
  implicit none
 
  character outbuf(OUTLSZ)      # Output line buffer.
  integer noutbf                # Number of characters in outbuf.
  character str(*)              # The string from which to output.
  integer i, n                  # Index and length of the substring.
 
  integer j
 
  for (j = 0; j < n; j = j + 1)
    call wrtchr (outbuf, noutbf, str(i + j))
end
 
subroutine wrtint (outbuf, noutbf, ival, colcnt)
 
  # Write an integer to output.
 
  implicit none
 
  character outbuf(OUTLSZ)    # Output line buffer.
  integer noutbf              # Number of characters in outbuf.
  integer ival                # The non-negative integer to print.
  integer colcnt              # Column count, or zero for free format.
 
  integer skipsp
 
  character*40 buf
  integer i, j
 
  write (buf, '(I40)') ival
  i = skipsp (buf, 1, 41)
  if (0 < colcnt)
    for (j = 1; j < colcnt - (40 - i); j = j + 1)
      call wrtchr (outbuf, noutbf, ' ')
  while (i <= 40)
    {
      call wrtchr (outbuf, noutbf, buf(i:i))
      i = i + 1
    }
end
 
#---------------------------------------------------------------------
 
function strnat (str, i, n)
 
  # Convert a string to a non-negative integer.
 
  implicit none
 
  character str(*)
  integer i, n
  integer strnat
 
  integer j
 
  strnat = 0
  for (j = 0; j < n; j = j + 1)
    strnat = (10 * strnat) + (ichar (str(i + j)) - ichar ('0'))
end
 
function strint (str, i, n)
 
  # Convert a string to an integer
 
  implicit none
 
  character str(*)
  integer i, n
  integer strint
 
  integer strnat
 
  if (str(i) == '-')
    strint = -strnat (str, i + 1, n - 1)
  else
    strint = strnat (str, i, n)
end
 
#---------------------------------------------------------------------
 
subroutine put1 (code, i, opcode)
 
  # Store a 1-byte operation.
 
  implicit none
 
  integer*1 code(0 : CODESZ - 1) # Byte code.
  integer i                      # Address to put the code at.
  integer*1 opcode
 
  if (CODESZ - i < 1)
    {
      write (*, '(''address beyond the size of memory'')')
      stop
    }
  code(i) = opcode
end
 
subroutine put5 (code, i, opcode, ival)
 
  # Store a 5-byte operation.
 
  implicit none
 
  integer*1 code(0 : CODESZ - 1) # Byte code.
  integer i                      # Address to put the code at.
  integer*1 opcode               #
  integer ival                   # Immediate integer value.
 
  integer*4 ival32
  integer*1 ival8(4)
  equivalence (ival32, ival8)
 
  if (CODESZ - i < 5)
    {
      write (*, '(''address beyond the size of memory'')')
      stop
    }
  code(i) = opcode
 
  # Native-endian storage.
  ival32 = ival
  code(i + 1) = ival8(1)
  code(i + 2) = ival8(2)
  code(i + 3) = ival8(3)
  code(i + 4) = ival8(4)
end
 
function getimm (code, i)
 
  # Get an immediate value from the code, at address i.
 
  implicit none
 
  integer*1 code(0 : CODESZ - 1) # Byte code.
  integer i                    # Address at which the integer resides.
  integer getimm               # Immediate integer value.
 
  integer*4 ival32
  integer*1 ival8(4)
  equivalence (ival32, ival8)
 
  if (i < 0 || CODESZ <= i + 3)
    {
      write (*, '(''code address out of range'')')
      stop
    }
 
  # Native-endian storage.
  ival8(1) = code(i)
  ival8(2) = code(i + 1)
  ival8(3) = code(i + 2)
  ival8(4) = code(i + 3)
  getimm = ival32
end
 
#---------------------------------------------------------------------
 
subroutine rdhead (datsiz, strsiz)
 
  # Read the header line.
 
  implicit none
 
  integer datsiz
  integer strsiz
 
  integer skipnd
  integer skipdg
  integer strnat
 
  character line(LINESZ)
  character*20 fmt
  integer i1, j1, i2, j2
 
  # Read a line of text as an array of characters.
  write (fmt, '(''('', I10, ''A)'')') LINESZ
  read (*, fmt) line
 
  i1 = skipnd (line, 1, LINESZ + 1)
  j1 = skipdg (line, i1, LINESZ + 1)
  i2 = skipnd (line, j1, LINESZ + 1)
  j2 = skipdg (line, i2, LINESZ + 1)
  if (i1 == j1 || i2 == j2)
    {
      write (*, '(''bad header line'')')
      stop
    }
  datsiz = strnat (line, i1, j1 - i1)
  strsiz = strnat (line, i2, j2 - i2)
end
 
subroutine rdstrs (strs, strsiz, strngs, istrng)
 
  implicit none
 
  integer strs(1:STRSZ, 0 : MAXSTR - 1)
  integer strsiz
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
 
  integer trimrt
  integer skipsp
 
  character line(LINESZ)
  character*20 fmt
  integer j
  integer i, n
  integer i0, n0
 
  # Read lines of text as an array of characters.
  write (fmt, '(''('', I10, ''A)'')') LINESZ
 
  for (j = 0; j < strsiz; j = j + 1)
    {
      read (*, fmt) line
      n0 = trimrt (line, LINESZ)
      i0 = skipsp (line, 1, n0 + 1)
      if (i0 == n0 + 1)
        {
          write (*, '(''blank line where a string should be'')')
          stop
        }
      call addstq (strngs, istrng, line, i0, n0 - i0 + 1, i, n)
      strs(STRI, j) = i
      strs(STRN, j) = n
    }
end
 
function stropc (str, i, n)
 
  # Convert substring to an opcode.
 
  implicit none
 
  character str(*)
  integer i, n
  integer*1 stropc
 
  stropc = -1
  if (n == 2)
    {
      if (str(i) == 'l')
        {
          if (str(i + 1) == 't')
            stropc = OPLT
          else if (str(i + 1) == 'e')
            stropc = OPLE
        }
      else if (str(i) == 'g')
        {
          if (str(i + 1) == 't')
            stropc = OPGT
          else if (str(i + 1) == 'e')
            stropc = OPGE
        }
      else if (str(i) == 'e' && str(i + 1) == 'q')
        stropc = OPEQ
      else if (str(i) == 'n' && str(i + 1) == 'e')
        stropc = OPNE
      else if (str(i) == 'o' && str(i + 1) == 'r')
        stropc = OPOR
      else if (str(i) == 'j' && str(i + 1) == 'z')
        stropc = OPJZ
    }
  else if (n == 3)
    {
      if (str(i) == 'a')
        {
          if (str(i + 1) == 'd' && str(i + 2) == 'd')
            stropc = OPADD
          else if (str(i + 1) == 'n' && str(i + 2) == 'd')
            stropc = OPAND
        }
      else if (str(i) == 'm')
        {
          if (str(i + 1) == 'o' && str(i + 2) == 'd')
            stropc = OPMOD
          else if (str(i + 1) == 'u' && str(i + 2) == 'l')
            stropc = OPMUL
        }
      else if (str(i) == 'n')
        {
          if (str(i + 1) == 'e' && str(i + 2) == 'g')
            stropc = OPNEG
          else if (str(i + 1) == 'o' && str(i + 2) == 't')
            stropc = OPNOT
        }
      else if (str(i) == 's' && str(i + 1) == 'u' _
                 && str(i + 2) == 'b')
        stropc = OPSUB
      else if (str(i) == 'd' && str(i + 1) == 'i' _
                 && str(i + 2) == 'v')
        stropc = OPDIV
      else if (str(i) == 'j' && str(i + 1) == 'm' _
                 && str(i + 2) == 'p')
        stropc = OPJMP
    }
  else if (n == 4)
    {
      if (str(i) == 'p')
        {
          if (str(i + 1) == 'r' && str(i + 2) == 't')
            {
              if (str(i + 3) == 'c')
                stropc = OPPRTC
              else if (str(i + 3) == 'i')
                stropc = OPPRTI
              else if (str(i + 3) == 's')
                stropc = OPPRTS
            }
          if (str(i + 1) == 'u' && str(i + 2) == 's' _
                && str(i + 3) == 'h')
            stropc = OPPUSH
        }
      else if (str(i) == 'h' && str(i + 1) == 'a' _
                 && str(i + 2) == 'l' && str(i + 3) == 't')
        stropc = OPHALT
    }
  else if (n == 5)
    {
      if (str(i) == 'f' && str(i + 1) == 'e' && str(i + 2) == 't' _
            && str(i + 3) == 'c' && str(i + 4) == 'h')
        stropc = OPFTCH
      if (str(i) == 's' && str(i + 1) == 't' && str(i + 2) == 'o' _
            && str(i + 3) == 'r' && str(i + 4) == 'e')
        stropc = OPSTOR
    }
  if (stropc == -1)
    {
      write (*, '(''unrecognized opcode name'')')
      stop
    }
end
 
subroutine rdops (code)
 
  # Read the opcodes and their immediate values.
 
  implicit none
 
  integer*1 code(0 : CODESZ - 1) # The byte code.
 
  integer trimrt
  integer skipsp
  integer skipal
  integer skipdg
  integer skipd1
  integer skipn1
  integer strnat
  integer strint
  integer*1 stropc
  character tolowr
 
  character line(LINESZ)
  character*20 fmt
  integer stat
  integer n
  integer j
  integer iaddr, jaddr          # Address index and size.
  integer iopnm, jopnm          # Opcode name index and size.
  integer iarg, jarg
  integer addr
  integer arg
  integer*1 opcode
 
  # Read lines of text as an array of characters.
  write (fmt, '(''('', I10, ''A)'')') LINESZ
 
  read (*, fmt, iostat = stat) line
  while (stat == 0)
    {
      n = trimrt (line, LINESZ)
 
      for (j = 1; j <= n; j = j + 1)
        line(j) = tolowr (line(j))
 
      iaddr = skipsp (line, 1, n + 1)
      jaddr = skipdg (line, iaddr, n + 1)
      addr = strnat (line, iaddr, jaddr - iaddr)
 
      iopnm = skipsp (line, jaddr, n + 1)
      jopnm = skipal (line, iopnm, n + 1)
      opcode = stropc (line, iopnm, jopnm - iopnm) 
 
      if (opcode == OPPUSH || opcode == OPFTCH || opcode == OPSTOR _
            || opcode == OPJMP || opcode == OPJZ)
        {
          iarg = skipn1 (line, jopnm, n + 1)
          jarg = skipd1 (line, iarg, n + 1)
          arg = strint (line, iarg, jarg - iarg)
          call put5 (code, addr, opcode, arg)
        }
      else
        call put1 (code, addr, opcode)
 
      read (*, fmt, iostat = stat) line
    }
end
 
subroutine rdcode (strs, strngs, istrng, code)
 
  # Read and parse the "assembly" code.
 
  implicit none
 
  integer strs(1:STRSZ, 0 : MAXSTR - 1)
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer*1 code(0 : CODESZ - 1) # The byte code.
 
  integer datsiz
  integer strsiz
 
  call rdhead (datsiz, strsiz)
  if (MAXVAR < datsiz)
    {
      write (*, '(''too many variables'')')
      stop
    }
  if (MAXSTR < strsiz)
    {
      write (*, '(''too many strings'')')
      stop
    }
 
  call rdstrs (strs, strsiz, strngs, istrng)
  call rdops (code)
end
 
#---------------------------------------------------------------------
 
subroutine stkbin (sp)
 
  implicit none
 
  integer sp
 
  if (sp < 3)
    {
      write (*, '(''stack underflow in binary operation'')')
      stop
    }
end
 
subroutine stkun (sp)
 
  implicit none
 
  integer sp
 
  if (sp < 2)
    {
      write (*, '(''stack underflow in unary operation'')')
      stop
    }
end
 
function logl2i (b)
 
  implicit none
 
  logical b
  integer logl2i
 
  if (b)
    logl2i = 1
  else
    logl2i = 0
end
 
subroutine rncode (strs, strngs, code, outbuf, noutbf)
 
  # Run the code.
 
  implicit none
 
  integer strs(1:STRSZ, 0 : MAXSTR - 1)
  character strngs(STRNSZ)       # String pool.
  integer*1 code(0 : CODESZ - 1) # The byte code.
  character outbuf(OUTLSZ)       # Output line buffer.
  integer noutbf                 # Number of characters in outbuf.
 
  integer logl2i
  integer getimm
  integer pop
 
  integer stack(STCKSZ)
  integer data(0 : MAXVAR - 1)
  integer sp                    # Stack pointer.
 
  integer pc                    # Program counter.
  integer ip                    # Instruction pointer.
  equivalence (pc, ip)          # LOL, use either name. :)
 
  integer i, n
  integer*1 opcode
  logical done
 
  sp = 1
  ip = 0
 
  done = .false.
  while (!done)
    {
      if (ip < 0 || CODESZ <= ip)
        {
          write (*, '(''code address out of range'')')
          stop
        }
      opcode = code(ip)
      ip = ip + 1
      if (opcode == OPADD)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = stack (sp - 1) + stack(sp)
        }
      else if (opcode == OPSUB)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = stack (sp - 1) - stack(sp)
        }
      else if (opcode == OPMUL)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = stack (sp - 1) * stack(sp)
        }
      else if (opcode == OPDIV)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = stack (sp - 1) / stack(sp)
        }
      else if (opcode == OPMOD)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = mod (stack (sp - 1), stack(sp))
        }
      else if (opcode == OPLT)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) < stack(sp))
        }
      else if (opcode == OPGT)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) > stack(sp))
        }
      else if (opcode == OPLE)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) <= stack(sp))
        }
      else if (opcode == OPGE)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) >= stack(sp))
        }
      else if (opcode == OPEQ)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) == stack(sp))
        }
      else if (opcode == OPNE)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) != stack(sp))
        }
      else if (opcode == OPAND)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = _
            logl2i (stack (sp - 1) != 0 && stack(sp) != 0)
        }
      else if (opcode == OPOR)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = _
            logl2i (stack (sp - 1) != 0 || stack(sp) != 0)
        }
      else if (opcode == OPNEG)
        {
          call stkun (sp)
          stack(sp - 1) = -stack(sp - 1)
        }
      else if (opcode == OPNOT)
        {
          call stkun (sp)
          stack(sp - 1) = logl2i (stack(sp - 1) == 0)
        }
      else if (opcode == OPPRTC)
        {
          call wrtchr (outbuf, noutbf, char (pop (stack, sp)))
        }
      else if (opcode == OPPRTI)
        {
          call wrtint (outbuf, noutbf, pop (stack, sp), 0)
        }
      else if (opcode == OPPRTS)
        {
          i = pop (stack, sp)
          if (i < 0 || MAXSTR <= i)
            {
              write (*, '(''string address out of range'')')
              stop
            }
          n = strs(STRN, i)
          i = strs(STRI, i)
          call wrtstr (outbuf, noutbf, strngs, i, n)
        }
      else if (opcode == OPFTCH)
        {
          i = getimm (code, ip)
          ip = ip + 4
          if (i < 0 || MAXVAR <= i)
            {
              write (*, '(''data address out of range'')')
              stop
            }
          call push (stack, sp, data(i))
        }
      else if (opcode == OPSTOR)
        {
          i = getimm (code, ip)
          ip = ip + 4
          if (i < 0 || MAXVAR <= i)
            {
              write (*, '(''data address out of range'')')
              stop
            }
          data(i) = pop (stack, sp)
        }
      else if (opcode == OPPUSH)
        {
          call push (stack, sp, getimm (code, ip))
          ip = ip + 4
        }
      else if (opcode == OPJMP)
        {
          ip = ip + getimm (code, ip)
        }
      else if (opcode == OPJZ)
        {
          if (pop (stack, sp) == 0)
            ip = ip + getimm (code, ip)
          else
            ip = ip + 4
        }
      else
        {
          # Halt on OPHALT or any unrecognized code.
          done = .true.
        }
    }
end
 
#---------------------------------------------------------------------
 
program vm
 
  implicit none
 
  integer strs(1:STRSZ, 0 : MAXSTR - 1)
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer*1 code(0 : CODESZ - 1) # The byte code.
  character outbuf(OUTLSZ)       # Output line buffer.
  integer noutbf                 # Number of characters in outbuf.
 
  integer j
 
  istrng = 1
  noutbf = 0
 
  for (j = 0; j < CODESZ; j = j + 1)
    code(j) = OPHALT
 
  call rdcode (strs, strngs, istrng, code)
  call rncode (strs, strngs, code, outbuf, noutbf)
 
  if (noutbf != 0)
    call flushl (outbuf, noutbf)
end
 
######################################################################