######################################################################
#
# The Rosetta Code AST interpreter in Ratfor 77.
#
#
# In FORTRAN 77 and therefore in Ratfor 77, there is no way to specify
# that a value should be put on a call stack. Therefore there is no
# way to implement recursive algorithms in Ratfor 77 (although see the
# Ratfor for the "syntax analyzer" task, where a recursive language is
# implemented *in* Ratfor). Thus we cannot simply follow the
# recursive pseudocode, and instead use non-recursive algorithms.
#
# How to deal with FORTRAN 77 input is another 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.
#
# Output is a bigger problem. If one uses gfortran, "advance='no'" is
# available, but not if one uses f2c. The method employed here is to
# construct the output in lines--regrettably, again, of fixed length.
#
#
# On a POSIX platform, the program can be compiled with f2c and run
# somewhat as follows:
#
#    ratfor77 interp-in-ratfor.r > interp-in-ratfor.f
#    f2c -C -Nc80 interp-in-ratfor.f
#    cc interp-in-ratfor.c -lf2c
#    ./a.out < compiler-tests/primes.ast
#
# With gfortran, a little differently:
#
#    ratfor77 interp-in-ratfor.r > interp-in-ratfor.f
#    gfortran -fcheck=all -std=legacy interp-in-ratfor.f
#    ./a.out < compiler-tests/primes.ast
#
#
# 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(NODSSZ, 4096)          # Size of the nodes pool.
define(STCKSZ, 4096)          # Size of stacks.
define(MAXVAR, 256)           # Maximum number of variables.

#---------------------------------------------------------------------

define(NEWLIN, 10)            # The Unix newline character (ASCII LF).
define(DQUOTE, 34)            # The double quote character.
define(BACKSL, 92)            # The backslash character.

#---------------------------------------------------------------------

define(NODESZ, 3)
define(NNEXTF, 1)               # Index for next-free.
define(NTAG,   1)               # Index for the tag.
                                # For an internal node --
define(NLEFT,  2)               #   Index for the left node.
define(NRIGHT, 3)               #   Index for the right node.
                                # For a leaf node --
define(NITV,   2)               #   Index for the string pool index.
define(NITN,   3)               #   Length of the value.

define(NIL, -1)                 # Nil node.

define(RGT, 10000)
define(STAGE2, 20000)

# The following all must be less than RGT.
define(NDID,    0)
define(NDSTR,   1)
define(NDINT,   2)
define(NDSEQ,   3)
define(NDIF,    4)
define(NDPRTC,  5)
define(NDPRTS,  6)
define(NDPRTI,  7)
define(NDWHIL,  8)
define(NDASGN,  9)
define(NDNEG,  10)
define(NDNOT,  11)
define(NDMUL,  12)
define(NDDIV,  13)
define(NDMOD,  14)
define(NDADD,  15)
define(NDSUB,  16)
define(NDLT,   17)
define(NDLE,   18)
define(NDGT,   19)
define(NDGE,   20)
define(NDEQ,   21)
define(NDNE,   22)
define(NDAND,  23)
define(NDOR,   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 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

#---------------------------------------------------------------------

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 addstu (strngs, istrng, src, i0, n0, i, n)

  # Add an unquoted 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

  if (STRNSZ < istrng + (n0 - 1))
    {
      write (*, '(''string pool exhausted'')')
      stop
    }
  for (j = 0; j < n0; j = j + 1)
    strngs(istrng + j) = src(i0 + j)
  i = istrng
  n = n0
  istrng = istrng + n0
end

subroutine addstr (strngs, istrng, src, i0, n0, i, n)

  # Add a string (possibly given as 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.

  if (n0 == 0)
    {
      i = 0
      n = 0
    }
  else if (src(i0) == char (DQUOTE))
    call addstq (strngs, istrng, src, i0, n0, i, n)
  else
    call addstu (strngs, istrng, src, i0, n0, i, n)
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 initnd (nodes, frelst)

  # Initialize the nodes pool.

  implicit none

  integer nodes (NODESZ, NODSSZ)
  integer frelst                # Head of the free list.

  integer i

  for (i = 1; i < NODSSZ; i = i + 1)
    nodes(NNEXTF, i) = i + 1
  nodes(NNEXTF, NODSSZ) = NIL
  frelst = 1
end

subroutine newnod (nodes, frelst, i)

  # Get the index for a new node taken from the free list.

  integer nodes (NODESZ, NODSSZ)
  integer frelst                # Head of the free list.
  integer i                     # Index of the new node.

  integer j

  if (frelst == NIL)
    {
      write (*, '(''nodes pool exhausted'')')
      stop
    }
  i = frelst
  frelst = nodes(NNEXTF, frelst)
  for (j = 1; j <= NODESZ; j = j + 1)
    nodes(j, i) = 0
end

subroutine frenod (nodes, frelst, i)

  # Return a node to the free list.

  integer nodes (NODESZ, NODSSZ)
  integer frelst                # Head of the free list.
  integer i                     # Index of the node to free.

  nodes(NNEXTF, i) = frelst
  frelst = i
end

function strtag (str, i, n)

  implicit none

  character str(*)
  integer i, n
  integer strtag

  character*16 s
  integer j

  for (j = 0; j < 16; j = j + 1)
    if (j < n)
      s(j + 1 : j + 1) = str(i + j)
    else
      s(j + 1 : j + 1) = ' '

  if (s == "Identifier      ")
    strtag = NDID
  else if (s == "String          ")
    strtag = NDSTR
  else if (s == "Integer         ")
    strtag = NDINT
  else if (s == "Sequence        ")
    strtag = NDSEQ
  else if (s == "If              ")
    strtag = NDIF
  else if (s == "Prtc            ")
    strtag = NDPRTC
  else if (s == "Prts            ")
    strtag = NDPRTS
  else if (s == "Prti            ")
    strtag = NDPRTI
  else if (s == "While           ")
    strtag = NDWHIL
  else if (s == "Assign          ")
    strtag = NDASGN
  else if (s == "Negate          ")
    strtag = NDNEG
  else if (s == "Not             ")
    strtag = NDNOT
  else if (s == "Multiply        ")
    strtag = NDMUL
  else if (s == "Divide          ")
    strtag = NDDIV
  else if (s == "Mod             ")
    strtag = NDMOD
  else if (s == "Add             ")
    strtag = NDADD
  else if (s == "Subtract        ")
    strtag = NDSUB
  else if (s == "Less            ")
    strtag = NDLT
  else if (s == "LessEqual       ")
    strtag = NDLE
  else if (s == "Greater         ")
    strtag = NDGT
  else if (s == "GreaterEqual    ")
    strtag = NDGE
  else if (s == "Equal           ")
    strtag = NDEQ
  else if (s == "NotEqual        ")
    strtag = NDNE
  else if (s == "And             ")
    strtag = NDAND
  else if (s == "Or              ")
    strtag = NDOR
  else if (s == ";               ")
    strtag = NIL
  else
    {
      write (*, '(''unrecognized input line: '', A16)') s
      stop
    }
end

subroutine readln (strngs, istrng, tag, iarg, narg)

  # Read a line of the AST input.

  implicit none

  character strngs(STRNSZ) # String pool.
  integer istrng           # String pool's next slot.
  integer tag              # The node tag or NIL.
  integer iarg             # Index of an argument in the string pool.
  integer narg             # Length of an argument in the string pool.

  integer trimrt
  integer strtag
  integer skipsp
  integer skipns

  character line(LINESZ)
  character*20 fmt
  integer i, j, n

  # Read a line of text as an array of characters.
  write (fmt, '(''('', I10, ''A)'')') LINESZ
  read (*, fmt) line

  n = trimrt (line, LINESZ)

  i = skipsp (line, 1, n + 1)
  j = skipns (line, i, n + 1)
  tag = strtag (line, i, j - i)

  i = skipsp (line, j, n + 1)
  call addstr (strngs, istrng, line, i, (n + 1) - i, iarg, narg)
end

function hasarg (tag)

  implicit none

  integer tag
  logical hasarg

  hasarg = (tag == NDID || tag == NDINT || tag == NDSTR)
end

subroutine rdast (strngs, istrng, nodes, frelst, iast)

  # Read in the AST. A non-recursive algorithm is used.

  implicit none

  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer nodes (NODESZ, NODSSZ) # Nodes pool.
  integer frelst                 # Head of the free list.
  integer iast                   # Index of root node of the AST.

  integer nstack
  integer pop
  logical hasarg

  integer stack(STCKSZ)
  integer sp                    # Stack pointer.
  integer tag, iarg, narg
  integer i, j, k

  sp = 1

  call readln (strngs, istrng, tag, iarg, narg)
  if (tag == NIL)
    iast = NIL
  else
    {
      call newnod (nodes, frelst, i)
      iast = i
      nodes(NTAG, i) = tag
      nodes(NITV, i) = 0
      nodes(NITN, i) = 0
      if (hasarg (tag))
        {
          nodes(NITV, i) = iarg
          nodes(NITN, i) = narg
        }
      else
        {
          call push (stack, sp, i + RGT)
          call push (stack, sp, i)
          while (nstack (sp) != 0)
            {
              j = pop (stack, sp)
              k = mod (j, RGT)
              call readln (strngs, istrng, tag, iarg, narg)
              if (tag == NIL)
                i = NIL
              else
                {
                  call newnod (nodes, frelst, i)
                  nodes(NTAG, i) = tag
                  if (hasarg (tag))
                    {
                      nodes(NITV, i) = iarg
                      nodes(NITN, i) = narg
                    }
                  else
                    {
                      call push (stack, sp, i + RGT)
                      call push (stack, sp, i)
                    }
                }
              if (j == k)
                nodes(NLEFT, k) = i
              else
                nodes(NRIGHT, k) = i
            }
        }
    }
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)

  # Write a non-negative 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 skipsp

  character*40 buf
  integer i

  # Using "write" probably is the slowest way one could think of to do
  # this, but people do formatted output all the time, anyway. :) The
  # reason, of course, is that output tends to be slow anyway.
  write (buf, '(I40)') ival
  for (i = skipsp (buf, 1, 41); i <= 40; i = i + 1)
    call wrtchr (outbuf, noutbf, buf(i:i))
end

#---------------------------------------------------------------------

define(VARSZ,  3)
define(VNAMEI, 1)          # Variable name's index in the string pool.
define(VNAMEN, 2)          # Length of the name.
define(VVALUE, 3)          # Variable's value.

function fndvar (vars, numvar, strngs, istrng, i0, n0)

  implicit none

  integer vars(VARSZ, MAXVAR)   # Variables.
  integer numvar                # Number of variables.
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  integer i0, n0                # Index and length in the string pool.
  integer fndvar                # The location of the variable.

  integer j, k
  integer i, n
  logical done1
  logical done2

  j = 1
  done1 = .false.
  while (!done1)
    if (j == numvar + 1)
      done1 = .true.
    else if (n0 == vars(VNAMEN, j))
      {
        k = 0
        done2 = .false.
        while (!done2)
          if (n0 <= k)
            done2 = .true.
          else if (strngs(i0 + k) == strngs(vars(VNAMEI, j) + k))
            k = k + 1
          else
            done2 = .true.
        if (k < n0)
          j = j + 1
        else
          {
            done2 = .true.
            done1 = .true.
          }
      }
    else
      j = j + 1

  if (j == numvar + 1)
    {
      if (numvar == MAXVAR)
        {
          write (*, '(''too many variables'')')
          stop
        }
      numvar = numvar + 1
      call addstu (strngs, istrng, strngs, i0, n0, i, n)
      vars(VNAMEI, numvar) = i
      vars(VNAMEN, numvar) = n
      vars(VVALUE, numvar) = 0
      fndvar = numvar
    }
  else
    fndvar = j
end

function strint (strngs, i, n)

  # Convert a string to a non-negative integer.

  implicit none

  character strngs(STRNSZ)       # String pool.
  integer i, n
  integer strint

  integer j

  strint = 0
  for (j = 0; j < n; j = j + 1)
    strint = (10 * strint) + (ichar (strngs(i + j)) - ichar ('0'))
end

function logl2i (u)

  # Convert LOGICAL to INTEGER.

  implicit none

  logical u
  integer logl2i

  if (u)
    logl2i = 1
  else
    logl2i = 0
end

subroutine run (vars, numvar, _
                strngs, istrng, _
                nodes, frelst, _
                outbuf, noutbf, iast)

  # Run (interpret) the AST. The algorithm employed is non-recursive.

  implicit none

  integer vars(VARSZ, MAXVAR)    # Variables.
  integer numvar                 # Number of variables.
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer nodes (NODESZ, NODSSZ) # Nodes pool.
  integer frelst                 # Head of the free list.
  character outbuf(OUTLSZ)       # Output line buffer.
  integer noutbf                 # Number of characters in outbuf.
  integer iast                   # Root node of the AST.

  integer fndvar
  integer logl2i
  integer nstack
  integer pop
  integer strint

  integer dstack(STCKSZ)        # Data stack.
  integer idstck                # Data stack pointer.
  integer xstack(STCKSZ)        # Execution stack.
  integer ixstck                # Execution stack pointer.
  integer i
  integer i0, n0
  integer tag
  integer ivar
  integer ival1, ival2
  integer inode1, inode2

  idstck = 1
  ixstck = 1
  call push (xstack, ixstck, iast)
  while (nstack (ixstck) != 0)
    {
      i = pop (xstack, ixstck)
      if (i == NIL)
        tag = NIL
      else
        tag = nodes(NTAG, i)
      if (tag == NIL)
        continue
      else if (tag == NDSEQ)
        {
          if (nodes(NRIGHT, i) != NIL)
            call push (xstack, ixstck, nodes(NRIGHT, i))
          if (nodes(NLEFT, i) != NIL)
            call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDID)
        {
          # Push the value of a variable.
          i0 = nodes(NITV, i)
          n0 = nodes(NITN, i)
          ivar = fndvar (vars, numvar, strngs, istrng, i0, n0)
          call push (dstack, idstck, vars(VVALUE, ivar))
        }
      else if (tag == NDINT)
        {
          # Push the value of an integer literal.
          i0 = nodes(NITV, i)
          n0 = nodes(NITN, i)
          call push (dstack, idstck, strint (strngs, i0, n0))
        }
      else if (tag == NDNEG)
        {
          # Evaluate the argument and prepare to negate it.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDNEG + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDNEG + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Negate the evaluated argument.
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, -ival1)
        }
      else if (tag == NDNOT)
        {
          # Evaluate the argument and prepare to NOT it.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDNOT + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDNOT + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # NOT the evaluated argument.
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 == 0))
        }
      else if (tag == NDAND)
        {
          # Evaluate the arguments and prepare to AND them.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDAND + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDAND + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # AND the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, _
                     logl2i (ival1 != 0 && ival2 != 0))
        }
      else if (tag == NDOR)
        {
          # Evaluate the arguments and prepare to OR them.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDOR + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDOR + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # OR the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, _
                     logl2i (ival1 != 0 || ival2 != 0))
        }
      else if (tag == NDADD)
        {
          # Evaluate the arguments and prepare to add them.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDADD + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDADD + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Add the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, ival1 + ival2)
        }
      else if (tag == NDSUB)
        {
          # Evaluate the arguments and prepare to subtract them.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDSUB + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDSUB + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Subtract the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, ival1 - ival2)
        }
      else if (tag == NDMUL)
        {
          # Evaluate the arguments and prepare to multiply them.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDMUL + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDMUL + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Multiply the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, ival1 * ival2)
        }
      else if (tag == NDDIV)
        {
          # Evaluate the arguments and prepare to compute the quotient
          # after division.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDDIV + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDDIV + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Divide the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, ival1 / ival2)
        }
      else if (tag == NDMOD)
        {
          # Evaluate the arguments and prepare to compute the
          # remainder after division.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDMOD + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDMOD + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # MOD the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, mod (ival1, ival2))
        }
      else if (tag == NDEQ)
        {
          # Evaluate the arguments and prepare to test their equality.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDEQ + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDEQ + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Test for equality.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 == ival2))
        }
      else if (tag == NDNE)
        {
          # Evaluate the arguments and prepare to test their
          # inequality.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDNE + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDNE + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Test for inequality.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 != ival2))
        }
      else if (tag == NDLT)
        {
          # Evaluate the arguments and prepare to test their
          # order.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDLT + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDLT + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Do the test.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 < ival2))
        }
      else if (tag == NDLE)
        {
          # Evaluate the arguments and prepare to test their
          # order.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDLE + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDLE + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Do the test.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 <= ival2))
        }
      else if (tag == NDGT)
        {
          # Evaluate the arguments and prepare to test their
          # order.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDGT + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDGT + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Do the test.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 > ival2))
        }
      else if (tag == NDGE)
        {
          # Evaluate the arguments and prepare to test their
          # order.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDGE + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDGE + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Do the test.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 >= ival2))
        }
      else if (tag == NDASGN)
        {
          # Prepare a new node to do the actual assignment.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDASGN + STAGE2
          nodes(NITV, inode1) = nodes(NITV, nodes(NLEFT, i))
          nodes(NITN, inode1) = nodes(NITN, nodes(NLEFT, i))
          call push (xstack, ixstck, inode1)
          # Evaluate the expression.
          call push (xstack, ixstck, nodes(NRIGHT, i))
        }
      else if (tag == NDASGN + STAGE2)
        {
          # Do the actual assignment, and free the STAGE2 node.
          i0 = nodes(NITV, i)
          n0 = nodes(NITN, i)
          call frenod (nodes, frelst, i)
          ival1 = pop (dstack, idstck)
          ivar = fndvar (vars, numvar, strngs, istrng, i0, n0)
          vars(VVALUE, ivar) = ival1
        }
      else if (tag == NDIF)
        {
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDIF + STAGE2
          # The "then" and "else" clauses, respectively:
          nodes(NLEFT, inode1) = nodes(NLEFT, nodes(NRIGHT, i))
          nodes(NRIGHT, inode1) = nodes(NRIGHT, nodes(NRIGHT, i))
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDIF + STAGE2)
        {
          inode1 = nodes(NLEFT, i)  # "Then" clause.
          inode2 = nodes(NRIGHT, i) # "Else" clause.
          call frenod (nodes, frelst, i)
          ival1 = pop (dstack, idstck)
          if (ival1 != 0)
            call push (xstack, ixstck, inode1)
          else if (inode2 != NIL)
            call push (xstack, ixstck, inode2)
        }
      else if (tag == NDWHIL)
        {
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDWHIL + STAGE2
          nodes(NLEFT, inode1) = nodes(NRIGHT, i) # Loop body.
          nodes(NRIGHT, inode1) = i               # Top of loop.
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDWHIL + STAGE2)
        {
          inode1 = nodes(NLEFT, i)  # Loop body.
          inode2 = nodes(NRIGHT, i) # Top of loop.
          call frenod (nodes, frelst, i)
          ival1 = pop (dstack, idstck)
          if (ival1 != 0)
            {
              call push (xstack, ixstck, inode2) # Top of loop.
              call push (xstack, ixstck, inode1) # The body.
            }
        }
      else if (tag == NDPRTS)
        {
          # Print a string literal. (String literals occur only--and
          # always--within Prts nodes; therefore one need not devise a
          # way push strings to the stack.)
          i0 = nodes(NITV, nodes(NLEFT, i))
          n0 = nodes(NITN, nodes(NLEFT, i))
          call wrtstr (outbuf, noutbf, strngs, i0, n0)
        }
      else if (tag == NDPRTC)
        {
          # Evaluate the argument and prepare to print it.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDPRTC + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDPRTC + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Print the evaluated argument.
          ival1 = pop (dstack, idstck)
          call wrtchr (outbuf, noutbf, char (ival1))
        }
      else if (tag == NDPRTI)
        {
          # Evaluate the argument and prepare to print it.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDPRTI + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDPRTI + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Print the evaluated argument.
          ival1 = pop (dstack, idstck)
          call wrtint (outbuf, noutbf, ival1)
        }
    }
end

#---------------------------------------------------------------------

program interp

  implicit none

  integer vars(VARSZ, MAXVAR)    # Variables.
  integer numvar                 # Number of variables.
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer nodes (NODESZ, NODSSZ) # Nodes pool.
  integer frelst                 # Head of the free list.
  character outbuf(OUTLSZ)       # Output line buffer.
  integer noutbf                 # Number of characters in outbuf.
  integer iast                   # Root node of the AST.

  numvar = 0
  istrng = 1
  noutbf = 0

  call initnd (nodes, frelst)
  call rdast (strngs, istrng, nodes, frelst, iast)

  call run (vars, numvar, _
            strngs, istrng, _
            nodes, frelst, _
            outbuf, noutbf, iast)

  if (noutbf != 0)
    call flushl (outbuf, noutbf)
end

######################################################################