######################################################################
#
# The Rosetta Code code generator 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). We are forced to 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.
#
#
# On a POSIX platform, the program can be compiled with f2c and run
# somewhat as follows:
#
#    ratfor77 gen-in-ratfor.r > gen-in-ratfor.f
#    f2c -C -Nc80 gen-in-ratfor.f
#    cc gen-in-ratfor.c -lf2c
#    ./a.out < compiler-tests/primes.ast
#
# With gfortran, a little differently:
#
#    ratfor77 gen-in-ratfor.r > gen-in-ratfor.f
#    gfortran -fcheck=all -std=legacy gen-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(MAXSTR, 256)           # Maximum number of strings.
define(CODESZ, 16384)         # Maximum size of a compiled program.

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

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)
define(STAGE3, 30000)
define(STAGE4, 40000)

# 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)

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

  # Add a 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
    }
  if (n0 == 0)
    {
      i = 0
      n = 0
    }
  else
    {
      for (j = 0; j < n0; j = j + 1)
        strngs(istrng + j) = src(i0 + j)
      i = istrng
      n = n0
      istrng = istrng + n0
    }
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, colcnt)

  # 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 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

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

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 number in the VM's data pool.

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 addstr (strngs, istrng, strngs, i0, n0, i, n)
      vars(VNAMEI, numvar) = i
      vars(VNAMEN, numvar) = n
      vars(VVALUE, numvar) = numvar - 1
      fndvar = numvar
    }
  else
    fndvar = j
end

define(STRSZ,  3)
define(STRI, 1)        # String's index in this program's string pool.
define(STRN, 2)        # Length of the string.
define(STRNO, 3)       # String's number in the VM's string pool.

function fndstr (strs, numstr, strngs, istrng, i0, n0)

  implicit none

  integer strs(STRSZ, MAXSTR)   # Strings for the VM's string pool.
  integer numstr                # Number of such strings.
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  integer i0, n0                # Index and length in the string pool.
  integer fndstr # The location of the string in the VM's string pool.

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

  j = 1
  done1 = .false.
  while (!done1)
    if (j == numstr + 1)
      done1 = .true.
    else if (n0 == strs(STRN, j))
      {
        k = 0
        done2 = .false.
        while (!done2)
          if (n0 <= k)
            done2 = .true.
          else if (strngs(i0 + k) == strngs(strs(STRI, 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 == numstr + 1)
    {
      if (numstr == MAXSTR)
        {
          write (*, '(''too many string literals'')')
          stop
        }
      numstr = numstr + 1
      call addstr (strngs, istrng, strngs, i0, n0, i, n)
      strs(STRI, numstr) = i
      strs(STRN, numstr) = n
      strs(STRNO, numstr) = numstr - 1
      fndstr = numstr
    }
  else
    fndstr = 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

subroutine put1 (code, ncode, i, opcode)

  # Store a 1-byte operation.

  implicit none

  integer code(0 : CODESZ - 1)  # Generated code.
  integer ncode                 # Number of VM bytes in the code.
  integer i                     # Address to put the code at.
  integer opcode

  if (CODESZ - i < 1)
    {
      write (*, '(''address beyond the size of memory'')')
      stop
    }
  code(i) = opcode
  ncode = max (ncode, i + 1)
end

subroutine put5 (code, ncode, i, opcode, ival)

  # Store a 5-byte operation.

  implicit none

  integer code(0 : CODESZ - 1)  # Generated code.
  integer ncode                 # Number of VM bytes in the code.
  integer i                     # Address to put the code at.
  integer opcode
  integer ival                  # Immediate integer value.

  if (CODESZ - i < 5)
    {
      write (*, '(''address beyond the size of memory'')')
      stop
    }
  code(i) = opcode
  code(i + 1) = ival  # Do not bother to break the integer into bytes.
  code(i + 2) = 0
  code(i + 3) = 0
  code(i + 4) = 0
  ncode = max (ncode, i + 5)
end

subroutine compil (vars, numvar, _
                   strs, numstr, _
                   strngs, istrng, _
                   nodes, frelst, _
                   code, ncode, iast)

  # Compile the AST to virtual machine code. The algorithm employed is
  # non-recursive.

  implicit none

  integer vars(VARSZ, MAXVAR)    # Variables.
  integer numvar                 # Number of variables.
  integer strs(STRSZ, MAXSTR)    # Strings for the VM's string pool.
  integer numstr                 # Number of such strings.
  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 code(0 : CODESZ - 1)   # Generated code.
  integer ncode                  # Number of VM bytes in the code.
  integer iast                   # Root node of the AST.

  integer fndvar
  integer fndstr
  integer nstack
  integer pop
  integer strint

  integer xstack(STCKSZ)        # Node stack.
  integer ixstck                # Node stack pointer.
  integer i
  integer i0, n0
  integer tag
  integer ivar
  integer inode1, inode2, inode3
  integer addr1, addr2

  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 < STAGE2)
        {
          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)
            {
              # Fetch the value of a variable.
              i0 = nodes(NITV, i)
              n0 = nodes(NITN, i)
              ivar = fndvar (vars, numvar, strngs, istrng, i0, n0)
              ivar = vars(VVALUE, ivar)
              call put5 (code, ncode, ncode, OPFTCH, ivar)
            }
          else if (tag == NDINT)
            {
              # Push the value of an integer literal.
              i0 = nodes(NITV, i)
              n0 = nodes(NITN, i)
              call put5 (code, ncode, ncode, OPPUSH, _
                         strint (strngs, i0, n0))
            }
          else if (tag == NDNEG)
            {
              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 == NDNOT)
            {
              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 == NDAND)
            {
              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 == NDOR)
            {
              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 == NDADD)
            {
              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 == NDSUB)
            {
              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 == NDMUL)
            {
              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 == NDDIV)
            {
              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 == NDMOD)
            {
              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 == NDLT)
            {
              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 == NDLE)
            {
              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 == NDGT)
            {
              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 == NDGE)
            {
              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 == NDEQ)
            {
              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 == NDNE)
            {
              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 == NDASGN)
            {
              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)
              call push (xstack, ixstck, nodes(NRIGHT, i))
            }
          else if (tag == NDPRTS)
            {
              i0 = nodes(NITV, nodes(NLEFT, i))
              n0 = nodes(NITN, nodes(NLEFT, i))
              ivar = fndstr (strs, numstr, strngs, istrng, i0, n0)
              ivar = strs(STRNO, ivar)
              call put5 (code, ncode, ncode, OPPUSH, ivar)
              call put1 (code, ncode, ncode, OPPRTS)
            }
          else if (tag == NDPRTC)
            {
              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 == NDPRTI)
            {
              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 == NDWHIL)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDWHIL + STAGE2
              nodes(NLEFT, inode1) = nodes(NRIGHT, i) # Loop body.
              nodes(NRIGHT, inode1) = ncode # Addr. of top of loop.
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          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 == NDNEG + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPNEG)
            }
          else if (tag == NDNOT + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPNOT)
            }
          else if (tag == NDAND + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPAND)
            }
          else if (tag == NDOR + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPOR)
            }
          else if (tag == NDADD + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPADD)
            }
          else if (tag == NDSUB + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPSUB)
            }
          else if (tag == NDMUL + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPMUL)
            }
          else if (tag == NDDIV + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPDIV)
            }
          else if (tag == NDMOD + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPMOD)
            }
          else if (tag == NDLT + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPLT)
            }
          else if (tag == NDLE + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPLE)
            }
          else if (tag == NDGT + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPGT)
            }
          else if (tag == NDGE + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPGE)
            }
          else if (tag == NDEQ + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPEQ)
            }
          else if (tag == NDNE + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPNE)
            }
          else if (tag == NDASGN + STAGE2)
            {
              i0 = nodes(NITV, i)
              n0 = nodes(NITN, i)
              call frenod (nodes, frelst, i)
              ivar = fndvar (vars, numvar, strngs, istrng, i0, n0)
              ivar = vars(VVALUE, ivar)
              call put5 (code, ncode, ncode, OPSTOR, ivar)
            }
          else if (tag == NDPRTC + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPPRTC)
            }
          else if (tag == NDPRTI + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPPRTI)
            }
          else if (tag == NDWHIL + STAGE2)
            {
              inode1 = nodes(NLEFT, i) # Loop body.
              addr1 = nodes(NRIGHT, i) # Addr. of top of loop.
              call frenod (nodes, frelst, i)
              call put5 (code, ncode, ncode, OPJZ, 0)
              call newnod (nodes, frelst, inode2)
              nodes(NTAG, inode2) = NDWHIL + STAGE3
              nodes(NLEFT, inode2) = addr1      # Top of loop.
              nodes(NRIGHT, inode2) = ncode - 4 # Fixup address.
              call push (xstack, ixstck, inode2)
              call push (xstack, ixstck, inode1)
            }
          else if (tag == NDWHIL + STAGE3)
            {
              addr1 = nodes(NLEFT, i)  # Top of loop.
              addr2 = nodes(NRIGHT, i) # Fixup address.
              call frenod (nodes, frelst, i)
              call put5 (code, ncode, ncode, OPJMP, addr1)
              code(addr2) = ncode
            }
          else if (tag == NDIF + STAGE2)
            {
              inode1 = nodes(NLEFT, i)  # "Then" clause.
              inode2 = nodes(NRIGHT, i) # "Else" clause.
              call frenod (nodes, frelst, i)
              call put5 (code, ncode, ncode, OPJZ, 0)
              call newnod (nodes, frelst, inode3)
              nodes(NTAG, inode3) = NDIF + STAGE3
              nodes(NLEFT, inode3) = ncode - 4 # Fixup address.
              nodes(NRIGHT, inode3) = inode2   # "Else" clause.
              call push (xstack, ixstck, inode3)
              call push (xstack, ixstck, inode1)
            }
          else if (tag == NDIF + STAGE3)
            {
              addr1 = nodes(NLEFT, i)   # Fixup address.
              inode1 = nodes(NRIGHT, i) # "Else" clause.
              call frenod (nodes, frelst, i)
              if (inode2 == NIL)
                code(addr1) = ncode
              else
                {
                  call put5 (code, ncode, ncode, OPJMP, 0)
                  addr2 = ncode - 4 # Another fixup address.
                  code(addr1) = ncode
                  call newnod (nodes, frelst, inode2)
                  nodes(NTAG, inode2) = NDIF + STAGE4
                  nodes(NLEFT, inode2) = addr2
                  call push (xstack, ixstck, inode2)
                  call push (xstack, ixstck, inode1)
                }
            }
          else if (tag == NDIF + STAGE4)
            {
              addr1 = nodes(NLEFT, i) # Fixup address.
              call frenod (nodes, frelst, i)
              code(addr1) = ncode
            }
        }
    }
  call put1 (code, ncode, ncode, OPHALT)
end

function opname (opcode)

  implicit none

  integer opcode
  character*8  opname

  if (opcode == OPHALT)
    opname = 'halt    '
  else if (opcode == OPADD)
    opname = 'add     '
  else if (opcode == OPSUB)
    opname = 'sub     '
  else if (opcode == OPMUL)
    opname = 'mul     '
  else if (opcode == OPDIV)
    opname = 'div     '
  else if (opcode == OPMOD)
    opname = 'mod     '
  else if (opcode == OPLT)
    opname = 'lt      '
  else if (opcode == OPGT)
    opname = 'gt      '
  else if (opcode == OPLE)
    opname = 'le      '
  else if (opcode == OPGE)
    opname = 'ge      '
  else if (opcode == OPEQ)
    opname = 'eq      '
  else if (opcode == OPNE)
    opname = 'ne      '
  else if (opcode == OPAND)
    opname = 'and     '
  else if (opcode == OPOR)
    opname = 'or      '
  else if (opcode == OPNEG)
    opname = 'neg     '
  else if (opcode == OPNOT)
    opname = 'not     '
  else if (opcode == OPPRTC)
    opname = 'prtc    '
  else if (opcode == OPPRTI)
    opname = 'prti    '
  else if (opcode == OPPRTS)
    opname = 'prts    '
  else if (opcode == OPFTCH)
    opname = 'fetch   '
  else if (opcode == OPSTOR)
    opname = 'store   '
  else if (opcode == OPPUSH)
    opname = 'push    '
  else if (opcode == OPJMP)
    opname = 'jmp     '
  else if (opcode == OPJZ)
    opname = 'jz      '
  else
    {
      write (*, '(''Unrecognized opcode: '', I5)') opcode
      stop
    }
end

subroutine prprog (numvar, strs, numstr, strngs, istrng, _
                   code, ncode, outbuf, noutbf)

  implicit none

  integer numvar                 # Number of variables.
  integer strs(STRSZ, MAXSTR)    # Strings for the VM's string pool.
  integer numstr                 # Number of such strings.
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer code(0 : CODESZ - 1)   # Generated code.
  integer ncode                  # Number of VM bytes in the code.
  character outbuf(OUTLSZ)       # Output line buffer.
  integer noutbf                 # Number of characters in outbuf.

  character*8 opname

  integer i0, n0
  integer i, j
  integer opcode
  character*8 name

  character buf(20)
  buf(1) = 'D'
  buf(2) = 'a'
  buf(3) = 't'
  buf(4) = 'a'
  buf(5) = 's'
  buf(6) = 'i'
  buf(7) = 'z'
  buf(8) = 'e'
  buf(9) = ':'
  buf(10) = ' '
  call wrtstr (outbuf, noutbf, buf, 1, 10)
  call wrtint (outbuf, noutbf, numvar, 0)
  buf(1) = ' '
  buf(2) = 'S'
  buf(3) = 't'
  buf(4) = 'r'
  buf(5) = 'i'
  buf(6) = 'n'
  buf(7) = 'g'
  buf(8) = 's'
  buf(9) = ':'
  buf(10) = ' '
  call wrtstr (outbuf, noutbf, buf, 1, 10)
  call wrtint (outbuf, noutbf, numstr, 0)
  call wrtchr (outbuf, noutbf, char (NEWLIN))

  for (i = 1; i <= numstr; i = i + 1)
    {
      i0 = strs(STRI, i)
      n0 = strs(STRN, i)
      call wrtstr (outbuf, noutbf, strngs, i0, n0)
      call wrtchr (outbuf, noutbf, char (NEWLIN))
    }

  i = 0
  while (i != ncode)
    {
      opcode = code(i)
      name = opname (opcode)
      call wrtint (outbuf, noutbf, i, 10)
      for (j = 1; j <= 2; j = j + 1)
        call wrtchr (outbuf, noutbf, ' ')
      for (j = 1; j <= 8; j = j + 1)
        {
          if (opcode == OPFTCH _
                || opcode == OPSTOR _
                || opcode == OPPUSH _
                || opcode == OPJMP _
                || opcode == OPJZ)
            call wrtchr (outbuf, noutbf, name(j:j))
          else if (name(j:j) != ' ')
            call wrtchr (outbuf, noutbf, name(j:j))
        }
      if (opcode == OPPUSH)
        {
          call wrtint (outbuf, noutbf, code(i + 1), 0)
          i = i + 5
        }
      else if (opcode == OPFTCH || opcode == OPSTOR)
        {
          call wrtchr (outbuf, noutbf, '[')
          call wrtint (outbuf, noutbf, code(i + 1), 0)
          call wrtchr (outbuf, noutbf, ']')
          i = i + 5
        }
      else if (opcode == OPJMP || opcode == OPJZ)
        {
          call wrtchr (outbuf, noutbf, '(')
          call wrtint (outbuf, noutbf, code(i + 1) - (i + 1), 0)
          call wrtchr (outbuf, noutbf, ')')
          call wrtchr (outbuf, noutbf, ' ')
          call wrtint (outbuf, noutbf, code(i + 1), 0)
          i = i + 5
        }
      else
        i = i + 1
      call wrtchr (outbuf, noutbf, char (NEWLIN))
    }
end

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

program gen

  implicit none

  integer vars(VARSZ, MAXVAR)    # Variables.
  integer numvar                 # Number of variables.
  integer strs(STRSZ, MAXSTR)    # Strings for the VM's string pool.
  integer numstr                 # Number of such strings.
  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 code(0 : CODESZ - 1)   # Generated code.
  integer ncode                  # Number of VM bytes in the code.
  integer iast                   # Root node of the AST.

  numvar = 0
  numstr = 0
  istrng = 1
  noutbf = 0
  ncode = 0

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

  call compil (vars, numvar, strs, numstr, _
               strngs, istrng, nodes, frelst, _
               code, ncode, iast)
  call prprog (numvar, strs, numstr, strngs, istrng, _
               code, ncode, outbuf, noutbf)

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

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