A code generator translates the output of the syntax analyzer and/or semantic analyzer
into lower level code, either assembly, object, or virtual.

Task[edit]
Take the output of the Syntax analyzer task - which is a flattened Abstract Syntax Tree (AST) - and convert it to virtual machine code, that can be run by the
Virtual machine interpreter. The output is in text format, and represents virtual assembly code.

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

Example - given the simple program (below), stored in a file called while.t, create the list of tokens, using one of the Lexical analyzer solutions
lex < while.t > while.lex

Run one of the Syntax analyzer solutions

parse < while.lex > while.ast

while.ast can be input into the code generator.
The following table shows the input to lex, lex output, the AST produced by the parser, and the generated virtual assembly code.
Run as:  lex < while.t | parse | gen



 Input to lex

 Output from lex, input to parse

 Output from parse

 Output from gen, input to VM



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


    1      1   Identifier      count
    1      7   Op_assign
    1      9   Integer              1
    1     10   Semicolon
    2      1   Keyword_while
    2      7   LeftParen
    2      8   Identifier      count
    2     14   Op_less
    2     16   Integer             10
    2     18   RightParen
    2     20   LeftBrace
    3      5   Keyword_print
    3     10   LeftParen
    3     11   String          "count is: "
    3     23   Comma
    3     25   Identifier      count
    3     30   Comma
    3     32   String          "\n"
    3     36   RightParen
    3     37   Semicolon
    4      5   Identifier      count
    4     11   Op_assign
    4     13   Identifier      count
    4     19   Op_add
    4     21   Integer              1
    4     22   Semicolon
    5      1   RightBrace
    6      1   End_of_input


Sequence
Sequence
;
Assign
Identifier    count
Integer       1
While
Less
Identifier    count
Integer       10
Sequence
Sequence
;
Sequence
Sequence
Sequence
;
Prts
String        "count is: "
;
Prti
Identifier    count
;
Prts
String        "\n"
;
Assign
Identifier    count
Add
Identifier    count
Integer       1


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

 Input format

As shown in the table, above, the output from the syntax analyzer is a flattened AST.

In the AST, Identifier, Integer, and String, are terminal nodes, e.g, they do not have child nodes.

Loading this data into an internal parse tree should be as simple as:

 
def load_ast()
    line = readline()
    # Each line has at least one token
    line_list = tokenize the line, respecting double quotes
 
    text = line_list[0] # first token is always the node type
 
    if text == ";"
        return None
 
    node_type = text # could convert to internal form if desired
 
    # A line with two tokens is a leaf node
    # Leaf nodes are: Identifier, Integer String
    # The 2nd token is the value
    if len(line_list) > 1
        return make_leaf(node_type, line_list[1])
 
    left = load_ast()
    right = load_ast()
    return make_node(node_type, left, right)
 
 Output format - refer to the table above
 The first line is the header: Size of data, and number of constant strings.
 size of data is the number of 32-bit unique variables used. In this example, one variable, count
 number of constant strings is just that - how many there are
 After that, the constant strings
 Finally, the assembly code
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
 
32-bit integers and strings

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

prtc

Print the word at stack top as a character.

prti

Print the word at stack top as an integer.

prts

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

halt

Unconditional stop.

 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
 Virtual Machine Interpreter task
 AST Interpreter task

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