Compiler/code generator: Difference between revisions

From Rosetta Code
Content added Content deleted
Line 7,249: Line 7,249:
60 jmp (-51) 10
60 jmp (-51) 10
65 halt</pre>
65 halt</pre>

=={{header|RATFOR}}==
{{works with|ratfor77|[https://sourceforge.net/p/chemoelectric/ratfor77/ public domain 1.0]}}
{{works with|gfortran|11.3.0}}
{{works with|f2c|20100827}}


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

######################################################################</lang>

{{out}}
<pre>$ ratfor77 gen-in-ratfor.r > gen-in-ratfor.f && gfortran -fcheck=all -std=legacy -O2 gen-in-ratfor.f && ./a.out < compiler-tests/primes.ast
Datasize: 5 Strings: 3
" is prime\n"
"Total primes found: "
"\n"
0 push 1
5 store [0]
10 push 1
15 store [1]
20 push 100
25 store [2]
30 fetch [1]
35 fetch [2]
40 lt
41 jz (160) 202
46 push 3
51 store [3]
56 push 1
61 store [4]
66 fetch [1]
71 push 2
76 add
77 store [1]
82 fetch [3]
87 fetch [3]
92 mul
93 fetch [1]
98 le
99 fetch [4]
104 and
105 jz (53) 159
110 fetch [1]
115 fetch [3]
120 div
121 fetch [3]
126 mul
127 fetch [1]
132 ne
133 store [4]
138 fetch [3]
143 push 2
148 add
149 store [3]
154 jmp (-73) 82
159 fetch [4]
164 jz (32) 197
169 fetch [1]
174 prti
175 push 0
180 prts
181 fetch [0]
186 push 1
191 add
192 store [0]
197 jmp (-168) 30
202 push 1
207 prts
208 fetch [0]
213 prti
214 push 2
219 prts
220 halt</pre>



=={{header|Scala}}==
=={{header|Scala}}==

Revision as of 21:32, 27 April 2022

Task
Compiler/code generator
You are encouraged to solve this task according to the task description, using any language you may know.

Code Generator

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

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

<lang c>count = 1; while (count < 10) { 

   print("count is: ", count, "\n");
   count = count + 1;

}</lang> 

    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:

<lang python> 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)

</lang>

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

ALGOL 68

Based on the Algol W sample. This generates .NET IL assembler code which can be compiled with the .NET ilasm assembler to generate an exe that can be run under Windows (and presumably Mono though I haven't tried that).
Apart from the namespace, class and method blocks surrounding the code, the main differences between IL and the task's assembly code are: no "compare-le", "compare-ge", "compare-ne", "prts", "prtc", "prti" and "not" instructions, symbolic labels are used and symbolic local variable names can be used. Some IL instructions have different names, e.g. "stloc" instead of "store". The "prt*" instructions are handled by calling the relevant System.Out.Print method. The compare and "not" instructions are handled by generating equivalent instruction sequences.
As noted in the code, the generated IL is naive - the sample focuses on simplicity. <lang algol68># RC Compiler code generator # COMMENT 

   this writes a .NET IL assembler source to standard output.
   If the output is stored in a file called "rcsample.il",
   it could be compiled the command:
       ilasm /opt /out:rcsample.exe rcsample.il
   (Note ilasm may not be in the PATH by default(

   Note: The generated IL is *very* naive

COMMENT

  1. parse tree nodes #

MODE NODE = STRUCT( INT type, REF NODE left, right, INT value ); INT nidentifier = 1, nstring = 2, ninteger = 3, nsequence = 4, nif = 5, nprtc = 6, nprts = 7 

 , nprti         =  8, nwhile     =  9, nassign   = 10, nnegate    = 11, nnot       = 12, nmultiply = 13, ndivide = 14
 , nmod          = 15, nadd       = 16, nsubtract = 17, nless      = 18, nlessequal = 19, ngreater  = 20
 , ngreaterequal = 21, nequal     = 22, nnotequal = 23, nand       = 24, nor        = 25
 ;
  1. op codes #

INT ofetch = 1, ostore = 2, opush = 3, oadd = 4, osub = 5, omul = 6, odiv = 7, omod = 8 

 , olt    =  9, ogt    = 10, ole   = 11, oge  = 12, oeq   = 13, one   = 14, oand  = 15, oor      = 16
 , oneg   = 17, onot   = 18, ojmp  = 19, ojz  = 20, oprtc = 21, oprts = 22, oprti = 23, opushstr = 24
 ;

[]INT ndop = ( -1 , -1 , -1 , -1 , -1 , -1 , -1 

 , -1               , -1             , -1            , oneg           , -1             , omul          , odiv
 , omod             , oadd           , osub          , olt            , -1             , ogt
 , -1               , oeq            , -1            , oand           , oor
 ) ;

[]STRING ndname = ( "Identifier" , "String" , "Integer" , "Sequence" , "If" , "Prtc" , "Prts" 

 , "Prti"           , "While"        , "Assign"      , "Negate"       , "Not"          , "Multiply"    , "Divide"
 , "Mod"            , "Add"          , "Subtract"    , "Less"         , "LessEqual"    , "Greater"
 , "GreaterEqual"   , "Equal"        , "NotEqual"    , "And"          , "Or"
 ) ;

[]STRING opname = ( "ldloc ", "stloc ", "ldc.i4 ", "add ", "sub ", "mul ", "div ", "rem " 

 , "clt    ",  "cgt    ",   "?le    ",  "?ge    ",  "ceq    ", "?ne    ",  "and    ",  "or     "
 , "neg    ",  "?not   ",   "br     ",  "brfalse",  "?prtc  ", "?prts  ",  "?prti  ",  "ldstr  "
 ) ;
  1. string and identifier arrays - a hash table might be better... #

INT max string number = 1024; [ 0 : max string number ]STRING identifiers, strings; FOR s pos FROM 0 TO max string number DO 

   identifiers[ s pos ] := "";
   strings    [ s pos ] := ""

OD;

  1. label number for label generation #

INT next label number := 0;

  1. returns the next free label number #

PROC new label = INT: next label number +:= 1;

  1. returns a new node with left and right branches #

PROC op node = ( INT op type, REF NODE left, right )REF NODE: HEAP NODE := NODE( op type, left, right, 0 );

  1. returns a new operand node #

PROC operand node = ( INT op type, value )REF NODE: HEAP NODE := NODE( op type, NIL, NIL, value );

  1. reports an error and stops #

PROC gen error = ( STRING message )VOID: 

    BEGIN
       print( ( message, newline ) );
       stop
    END # gen error # ;
  1. reads a node from standard input #

PROC read node = REF NODE: 

    BEGIN
       REF NODE result := NIL;

       # parses a string from line and stores it in a string in the text array #
       # - if it is not already present in the specified textElement list.     #
       # returns the position of the string in the text array                  #
       PROC read string = ( REF[]STRING text list, CHAR terminator )INT:
            BEGIN
               # get the text of the string #
               STRING str := line[ l pos ];
               l pos +:= 1;
               WHILE IF l pos <= UPB line THEN line[ l pos ] /= terminator ELSE FALSE FI DO
                   str   +:= line[ l pos ];
                   l pos +:= 1
               OD;
               IF l pos > UPB line THEN gen error( "Unterminated String in node file: (" + line + ")." ) FI;
               # attempt to find the text in the list of strings/identifiers #
               INT  t pos  := LWB text list;
               BOOL found  := FALSE;
               INT  result := LWB text list - 1;
               FOR t pos FROM LWB text list TO UPB text list WHILE NOT found DO
                   IF found := text list[ t pos ] = str THEN
                       # found the string #
                       result := t pos
                   ELIF text list[ t pos ] = "" THEN
                       # have an empty slot for ther string #
                       found := TRUE;
                       text list[ t pos ] := str;
                       result := t pos
                   FI
               OD;
               IF NOT found THEN gen error( "Out of string space." ) FI;
               result
            END # read string # ;
       # gets an integer from the line - no checks for valid digits #
       PROC read integer = INT:
            BEGIN
                INT n := 0;
                WHILE line[ l pos ] /= " " DO
                    ( n *:= 10 ) +:= ( ABS line[ l pos ] - ABS "0" );
                    l pos +:= 1
                OD;
                n
            END # read integer # ;

       STRING line, name;
       INT    l pos := 1, nd type := -1;
       read( ( line, newline ) );
       line +:= " ";
       # get the node type name #
       WHILE line[ l pos ] = " " DO l pos +:= 1 OD;
       name := "";
       WHILE IF l pos > UPB line THEN FALSE ELSE line[ l pos ] /= " " FI DO
           name +:= line[ l pos ];
           l pos +:= 1
       OD;
       # determine the node type #
       nd type := LWB nd name;
       IF name /= ";" THEN
           # not a null node #
           WHILE IF nd type <= UPB nd name THEN name /= nd name[ nd type ] ELSE FALSE FI DO nd type +:= 1 OD;
           IF nd type > UPB nd name THEN gen error( "Malformed node: (" + line + ")." ) FI;
           # handle the additional parameter for identifier/string/integer, or sub-nodes for operator nodes #
           IF nd type = ninteger OR nd type = nidentifier OR nd type = nstring THEN
               WHILE line[ l pos ] = " " DO l pos +:= 1 OD;
               IF     nd type = ninteger    THEN result := operand node( nd type, read integer )
               ELIF   nd type = nidentifier THEN result := operand node( nd type, read string( identifiers, " "  ) )
               ELSE # nd type = nString     #    result := operand node( nd type, read string( strings,     """" ) )
               FI
           ELSE
               # operator node #
               REF NODE left node = read node;
               result := op node( nd type, left node, read node )
           FI
       FI;
       result
    END # read node # ;
  1. returns a formatted op code for code generation #

PROC operation = ( INT op code )STRING: " " + op name[ op code ] + " ";

  1. defines the specified label #

PROC define label = ( INT label number )VOID: print( ( "lbl_", whole( label number, 0 ), ":", newline ) );

  1. generates code to load a string value #

PROC gen load string = ( INT value )VOID: 

    BEGIN
       print( ( operation( opushstr ), "  ", strings[ value ], """", newline ) )
    END # push string # ;
  1. generates code to load a constant value #

PROC gen load constant = ( INT value )VOID: print( ( operation( opush ), " ", whole( value, 0 ), newline ) );

  1. generates an operation acting on an address #

PROC gen data op = ( INT op, address )VOID: print( ( operation( op ), " l_", identifiers[ address ], newline ) );

  1. generates a nullary operation #

PROC gen op 0 = ( INT op )VOID: print( ( operation( op ), newline ) );

  1. generates a "not" instruction sequence #

PROC gen not = VOID: 

    BEGIN
       gen load constant( 0 );
       print( ( operation( oeq ), newline ) )
    END # gen not # ;
  1. generates a negated condition #

PROC gen not op = ( INT op, REF NODE n )VOID: 

    BEGIN
       gen(  left OF n );
       gen( right OF n );
       gen op 0( op );
       gen not
    END # gen not op # ;
  1. generates a jump operation #

PROC gen jump = ( INT op, label )VOID: print( ( operation( op ), " lbl_", whole( label, 0 ), newline ) );

  1. generates code to output something to System.Console.Out #

PROC gen output = ( REF NODE n, STRING output type )VOID: 

    BEGIN
       print( ( "            call       " ) );
       print( ( "class [mscorlib]System.IO.TextWriter [mscorlib]System.Console::get_Out()", newline ) );
       gen( left OF n );
       print( ( "            callvirt   " ) );
       print( ( "instance void [mscorlib]System.IO.TextWriter::Write(", output type, ")", newline ) )
    END # gen output # ;
  1. generates the code header - assembly info, namespace, class and start of the Main method #

PROC code header = VOID: 

    BEGIN
       print( ( ".assembly extern mscorlib { auto }",                                  newline ) );
       print( ( ".assembly RccSample {}",                                              newline ) );
       print( ( ".module RccSample.exe",                                               newline ) );
       print( ( ".namespace Rcc.Sample",                                               newline ) );
       print( ( "{",                                                                   newline ) );
       print( ( "    .class public auto ansi Program extends [mscorlib]System.Object", newline ) );
       print( ( "    {",                                                               newline ) );
       print( ( "        .method public static void Main() cil managed",               newline ) );
       print( ( "        {",                                                           newline ) );
       print( ( "           .entrypoint",                                              newline ) );
       # output the local variables #
       BOOL   have locals  := FALSE;
       STRING local prefix := "           .locals init (int32 l_";
       FOR s pos FROM LWB identifiers TO UPB identifiers WHILE identifiers[ s pos ] /= "" DO
           print( ( local prefix, identifiers[ s pos ], newline ) );
           local prefix := "                        ,int32 l_";
           have locals  := TRUE
       OD;
       IF have locals THEN
           # there were some local variables defined - output the terminator #
           print( ( "                        )", newline ) )
       FI
    END # code header # ;
  1. generates code for the node n #

PROC gen = ( REF NODE n )VOID: 

    IF n IS REF NODE( NIL )        THEN # null node       #
       SKIP
    ELIF type OF n = nidentifier   THEN # load identifier #
       gen data op( ofetch, value OF n )
    ELIF type OF n = nstring       THEN # load string     #
       gen load string( value OF n )
    ELIF type OF n = ninteger      THEN # load integer    #
       gen load constant( value OF n )
    ELIF type OF n = nsequence     THEN # list            #
       gen(  left OF n );
       gen( right OF n )
    ELIF type OF n = nif           THEN # if-else         #
       INT else label := new label;
       gen( left OF n );
       gen jump( ojz, else label );
       gen( left OF right OF n );
       IF right OF right OF n IS REF NODE( NIL ) THEN
           # no "else" part #
           define label( else label )
       ELSE
           # have an "else" part #
           INT end if label := new label;
           gen jump( ojmp, end if label );
           define label( else label );
           gen( right OF right OF n );
           define label( end if label )
       FI
    ELIF type OF n = nwhile        THEN # while-loop      #
       INT loop label := new label;
       INT exit label := new label;
       define label( loop label );
       gen(  left OF n );
       gen jump( ojz,  exit label );
       gen( right OF n );
       gen jump( ojmp, loop label );
       define label( exit label )
    ELIF type OF n = nassign       THEN # assignment      #
       gen( right OF n );
       gen data op( ostore, value OF left OF n )
    ELIF type OF n = nnot          THEN # bolean not      #
       gen( left OF n );
       gen not
    ELIF type OF n = ngreaterequal THEN # compare >=      #
       gen not op( olt, n )
    ELIF type OF n = nnotequal     THEN # compare not =   #
       gen not op( oeq, n )
    ELIF type OF n = nlessequal    THEN # compare <=      #
       gen not op( ogt, n )
    ELIF type OF n = nprts         THEN # print string    #
       gen output( n, "string" )
    ELIF type OF n = nprtc         THEN # print character #
       gen output( n, "char" )
    ELIF type OF n = nprti         THEN # print integer   #
       gen output( n, "int32" )
    ELSE                                # everything else #
       gen(  left OF n );
       gen( right OF n ); # right will be null for a unary op so no code will be generated #
       print( ( operation( ndop( type OF n ) ), newline ) )
    FI # gen # ;
  1. generates the code trailer - return instruction, end of Main method, end of class and end of namespace #

PROC code trailer = VOID: 

    BEGIN
       print( ( "            ret",           newline ) );
       print( ( "        } // Main method",  newline ) );
       print( ( "    } // Program class",    newline ) );
       print( ( "} // Rcc.Sample namespace", newline ) )
    END # code trailer # ;
  1. parse the output from the syntax analyser and generate code from the parse tree #

REF NODE code = read node; code header; gen( code ); code trailer</lang>

Output:
.assembly extern mscorlib { auto }
.assembly RccSample {}
.module RccSample.exe
.namespace Rcc.Sample
{
    .class public auto ansi Program extends [mscorlib]System.Object
    {
        .method public static void Main() cil managed
        {
           .entrypoint
           .locals init (int32 l_count
                        )
            ldc.i4     1
            stloc      l_count
lbl_1:
            ldloc      l_count
            ldc.i4     10
            clt      
            brfalse    lbl_2
            call       class [mscorlib]System.IO.TextWriter [mscorlib]System.Console::get_Out()
            ldstr      "count is: "
            callvirt   instance void [mscorlib]System.IO.TextWriter::Write(string)
            call       class [mscorlib]System.IO.TextWriter [mscorlib]System.Console::get_Out()
            ldloc      l_count
            callvirt   instance void [mscorlib]System.IO.TextWriter::Write(int32)
            call       class [mscorlib]System.IO.TextWriter [mscorlib]System.Console::get_Out()
            ldstr      "\n"
            callvirt   instance void [mscorlib]System.IO.TextWriter::Write(string)
            ldloc      l_count
            ldc.i4     1
            add      
            stloc      l_count
            br         lbl_1
lbl_2:
            ret
        } // Main method
    } // Program class
} // Rcc.Sample namespace

ALGOL W

<lang algolw>begin % code generator % 

   % parse tree nodes %
   record node( integer         type
              ; reference(node) left, right
              ; integer         iValue % nString/nIndentifier number or nInteger value %
              );
   integer    nIdentifier, nString, nInteger, nSequence, nIf,   nPrtc, nPrts
         ,    nPrti,       nWhile,  nAssign,  nNegate,   nNot,  nMultiply
         ,    nDivide,     nMod,    nAdd,     nSubtract, nLess, nLessEqual
         ,    nGreater,    nGreaterEqual,     nEqual,    nNotEqual,    nAnd, nOr
         ;
   string(14) array ndName ( 1 :: 25 );
   integer    array nOp    ( 1 :: 25 );
   integer    MAX_NODE_TYPE;
   % string literals and identifiers - uses a linked list - a hash table might be better... %
   string(1)  array text ( 0 :: 4095 );
   integer    textNext, TEXT_MAX;
   record textElement ( integer start, length; reference(textElement) next );
   reference(textElement) idList, stList;
   % op codes %
   integer    oFetch, oStore, oPush
         ,    oAdd,   oSub,   oMul, oDiv, oMod, oLt, oGt,   oLe,   oGe,   oEq,  oNe
         ,    oAnd,   oOr,    oNeg, oNot, oJmp, oJz, oPrtc, oPrts, oPrti, oHalt
         ;
   string(6)  array opName ( 1 :: 24 );
   % code - although this is intended to be byte code, as we are going to output    %
   %        an assembler source, we use integers for convenience                    %
   % labelLocations are: - ( referencing location + 1 ) if they have been referenced but not defined yet, %
   %                     zero     if they are unreferenced and undefined,                                 %
   %                     ( referencing location + 1 )   if they are defined                               %
   integer    array byteCode ( 0 :: 4095 );
   integer    array labelLocation( 1 :: 4096 );
   integer    nextLocation, MAX_LOCATION, nextLabelNumber, MAX_LABEL_NUMBER;

   % returns a new node with left and right branches %
   reference(node) procedure opNode ( integer value opType; reference(node) value opLeft, opRight ) ; begin
       node( opType, opLeft, opRight, 0 )
   end opNode ;

   % returns a new operand node %
   reference(node) procedure operandNode ( integer value opType, opValue ) ; begin
       node( opType, null, null, opValue )
   end operandNode ;

   % reports an error and stops %
   procedure genError( string(80) value message ); begin
       integer errorPos;
       write( s_w := 0, "**** Code generation error: " );
       errorPos := 0;
       while errorPos < 80 and message( errorPos // 1 ) not = "." do begin
           writeon( s_w := 0, message( errorPos // 1 ) );
           errorPos := errorPos + 1
       end while_not_at_end_of_message ;
       writeon( s_w := 0, "." );
       assert( false )
   end genError ;

   % reads a node from standard input %
   reference(node) procedure readNode ; begin
       reference(node) resultNode;

       % parses a string from line and stores it in a string in the text array %
       % - if it is not already present in the specified textElement list.     %
       % returns the position of the string in the text array                  %
       integer procedure readString ( reference(textElement) value result txList; string(1) value terminator ) ; begin
           string(256) str;
           integer     sLen, sPos, ePos;
           logical     found;
           reference(textElement) txPos, txLastPos;
           % get the text of the string %
           str  := " ";
           sLen := 0;
           str( sLen // 1 ) := line( lPos // 1 );
           sLen := sLen + 1;
           lPos := lPos + 1;
           while lPos <= 255 and line( lPos // 1 ) not = terminator do begin
               str( sLen // 1 ) := line( lPos // 1 );
               sLen := sLen + 1;
               lPos := lPos + 1
           end while_more_string ;
           if lPos > 255 then genError( "Unterminated String in node file." );
           % attempt to find the text in the list of strings/identifiers %
           txLastPos := txPos := txList;
           found := false;
           ePos := 0;
           while not found and txPos not = null do begin
               ePos  := ePos + 1;
               found := ( length(txPos) = sLen );
               sPos  := 0;
               while found and sPos < sLen do begin
                   found := str( sPos // 1 ) = text( start(txPos) + sPos );
                   sPos  := sPos + 1
               end while_not_found ;
               txLastPos := txPos;
               if not found then txPos := next(txPos)
           end while_string_not_found ;
           if not found then begin
               % the string/identifier is not in the list - add it %
               ePos := ePos + 1;
               if txList = null then txList := textElement( textNext, sLen, null )
                                else next(txLastPos) := textElement( textNext, sLen, null );
               if textNext + sLen > TEXT_MAX then genError( "Text space exhausted." )
               else begin
                   for cPos := 0 until sLen - 1 do begin
                       text( textNext ) := str( cPos // 1 );
                       textNext := textNext + 1
                   end for_cPos
               end
           end if_not_found ;
           ePos
       end readString ;

       % gets an integer from the line - no checks for valid digits %
       integer procedure readInteger ; begin
           integer n;
           n := 0;
           while line( lPos // 1 ) not = " " do begin
               n    := ( n * 10 ) + ( decode( line( lPos // 1 ) ) - decode( "0" ) );
               lPos := lPos + 1
           end while_not_end_of_integer ;
           n
       end readInteger ;

       string(256) line;
       string(16)  name;
       integer     lPos, tPos, ndType;
       tPos := lPos := 0;
       readcard( line );
       % get the node type name %
       while line( lPos // 1 ) = " " do lPos := lPos + 1;
       name := "";
       while lPos < 256 and line( lPos // 1 ) not = " " do begin
           name( tPos // 1 ) := line( lPos // 1 );
           lPos := lPos + 1;
           tPos := tPos + 1
       end  while_more_name ;
       % determine the node type %
       ndType         := 1;
       resultNode     := null;
       if name not = ";" then begin
           % not a null node %
           while ndType <= MAX_NODE_TYPE and name not = ndName( ndType ) do ndType := ndType + 1;
           if ndType > MAX_NODE_TYPE then genError( "Malformed node." );
           % handle the additional parameter for identifier/string/integer, or sub-nodes for operator nodes %
           if ndType = nInteger or ndType = nIdentifier or ndType = nString then begin
               while line( lPos // 1 ) = " " do lPos := lPos + 1;
               if      ndType = nInteger    then resultNode := operandNode( ndType, readInteger )
               else if ndType = nIdentifier then resultNode := operandNode( ndType, readString( idList, " "  ) )
               else  % ndType = nString     %    resultNode := operandNode( ndType, readString( stList, """" ) )
               end
           else begin
               % operator node %
               reference(node) leftNode;
               leftNode   := readNode;
               resultNode := opNode( ndType, leftNode, readNode )
           end
       end if_non_null_node ;
       resultNode
   end readNode ;

   % returns the next free label number %
   integer procedure newLabel ; begin
       nextLabelNumber := nextLabelNumber + 1;
       if nextLabelNumber > MAX_LABEL_NUMBER then genError( "Program too complex" );
       nextLabelNumber
   end newLabel ;

   % defines the specified label to be at the next location %
   procedure defineLabel ( integer value labelNumber ) ; begin
       if labelLocation( labelNumber ) > 0 then genError( "Label already defined" )
       else begin
           % this is the first definition of the label, define it and if it has already been referenced, fill in the reference %
           integer currValue;
           currValue := labelLocation( labelNumber );
           labelLocation( labelNumber ) := nextLocation + 1; % we store pc + 1 to ensure the label location is positive %
           if currValue < 0 then % already referenced % byteCode( - ( currValue + 1 ) ) := labelLocation( labelNumber )
       end
   end defineLabel ;

   % stores a byte in the code %
   procedure genByte ( integer value byteValue ) ; begin
       if nextLocation > MAX_LOCATION then genError( "Program too large" );
       byteCode( nextLocation ) := byteValue;
       nextLocation := nextLocation + 1
   end genByte ;

   % stores an integer in the code %
   procedure genInteger ( integer value integerValue ) ; begin
       % we are storing the bytes of the code in separate integers for convenience %
       genByte( integerValue ); genByte( 0 ); genByte( 0 ); genByte( 0 )
   end genInteger ;

   % generates an operation acting on an address %
   procedure genDataOp ( integer value opCode, address ) ; begin
       genByte( opCode );
       genInteger( address )
   end genDataOp ;

   % generates a nullary operation %
   procedure genOp0  ( integer value opCode ) ; begin
       genByte( opCode )
   end genOp0 ;

   % generates a unary/binary operation %
   procedure genOp ( reference(node) value n ) ; begin
       gen(  left(n) );
       gen( right(n) ); % right will be null for a unary op so no code will be generated %
       genByte( nOp( type(n) ) )
   end genOp ;

   % generates a jump operation %
   procedure genJump   ( integer value opCode, labelNumber ) ; begin
       genByte( opCode );
       % if the label is not defined yet - set it's location to the negative of the referencing location %
       % so it can be resolved later %
       if labelLocation( labelNumber ) = 0 then labelLocation( labelNumber ) := - ( nextLocation + 1 );
       genInteger( labelLocation( labelNumber ) )
   end genJump ;

   % generates code for the node n %
   procedure gen ( reference(node) value n ) ; begin

       if           n  = null        then % empty node % begin end
       else if type(n) = nIdentifier then genDataOp( oFetch, iValue(n) )
       else if type(n) = nString     then genDataOp( oPush,  iValue(n) - 1 )
       else if type(n) = nInteger    then genDataOp( oPush,  iValue(n) )
       else if type(n) = nSequence   then begin
           gen(  left(n) );
           gen( right(n) )
           end
       else if type(n) = nIf         then % if-else         % begin
           integer elseLabel;
           elseLabel := newLabel;
           gen( left(n) );
           genJump( oJz, elseLabel );
           gen( left( right(n) ) );
           if right(right(n)) = null then % no "else" part % defineLabel( elseLabel )
           else begin
               % have an "else" part %
               integer endIfLabel;
               endIfLabel := newLabel;
               genJump( oJmp, endIfLabel );
               defineLabel( elseLabel );
               gen( right(right(n)) );
               defineLabel( endIfLabel )
           end
           end
       else if type(n) = nWhile      then % while-loop      % begin
           integer loopLabel, exitLabel;
           loopLabel := newLabel;
           exitLabel := newLabel;
           defineLabel( loopLabel );
           gen(  left(n) );
           genJump( oJz,  exitLabel );
           gen( right(n) );
           genJump( oJmp, loopLabel );
           defineLabel( exitLabel )
           end
       else if type(n) = nAssign     then % assignment      % begin
           gen( right( n ) );
           genDataOp( oStore, iValue(left(n)) )
           end
       else genOp( n )
   end gen ;

   % outputs the generated code to standard output %
   procedure emitCode ; begin

       % counts the number of elements in a text element list %
       integer procedure countElements ( reference(textElement) value txHead ) ; begin
           integer count;
           reference(textElement) txPos;
           count := 0;
           txPos := txHead;
           while txPos not = null do begin
               count := count + 1;
               txPos := next(txPos)
           end while_txPos_not_null ;
           count
       end countElements ;

       integer pc, op;
       reference(textElement) txPos;

       % code header %
       write( i_w := 1, s_w := 0
            , "Datasize: ", countElements( idList )
            , " Strings: ", countElements( stList )
            );
       % output the string literals %
       txPos := stList;
       while txPos not = null do begin
           integer cPos;
           write( """" );
           cPos := 1; % start from 1 to skip over the leading " %
           while cPos < length(txPos) do begin
               writeon( s_w := 0, text( start(txPos) + cPos ) );
               cPos := cPos + 1
           end while_not_end_of_string ;
           writeon( s_w := 0, """" );
           txPos := next(txPos)
       end while_not_at_end_of_literals ;

       % code body %
       pc := 0;
       while pc < nextLocation do begin
           op := byteCode( pc );
           write( i_w := 4, s_w := 0, pc, " ", opName( op ) );
           pc := pc + 1;
           if      op = oFetch or op = oStore then begin
               % data load/store - add the address in square brackets %
               writeon( i_w := 1, s_w := 0, "[", byteCode( pc ) - 1, "]" );
               pc := pc + 4
               end
           else if op = oPush                 then begin
               % push constant - add the constant %
               writeon( i_w := 1, s_w := 0, byteCode( pc ) );
               pc := pc + 4
               end
           else if op = oJmp   or op = oJz    then begin
               % jump - show the relative address in brackets and the absolute address %
               writeon( i_w := 1, s_w := 0, "(", ( byteCode( pc ) - 1 ) - pc, ") ", byteCode( pc ) - 1 );
               pc := pc + 4
           end
       end while_pc_lt_nextLocation
   end emitCode ;

   oFetch :=  1; opName( oFetch ) := "fetch"; oStore :=  2; opName( oStore ) := "store"; oPush :=  3; opName( oPush ) := "push";
   oAdd   :=  4; opName( oAdd   ) := "add";   oSub   :=  5; opName( oSub   ) := "sub";   oMul  :=  6; opName( oMul  ) := "mul";
   oDiv   :=  7; opName( oDiv   ) := "div";   oMod   :=  8; opName( oMod   ) := "mod";   oLt   :=  9; opName( oLt   ) := "lt";
   oGt    := 10; opName( oGt    ) := "gt";    oLe    := 11; opName( oLe    ) := "le";    oGe   := 12; opName( oGe   ) := "ge";
   oEq    := 13; opName( oEq    ) := "eq";    oNe    := 14; opName( oNe    ) := "ne";    oAnd  := 15; opName( oAnd  ) := "and";
   oOr    := 16; opName( oOr    ) := "or";    oNeg   := 17; opName( oNeg   ) := "neg";   oNot  := 18; opName( oNot  ) := "not";
   oJmp   := 19; opName( oJmp   ) := "jmp";   oJz    := 20; opName( oJz    ) := "jz";    oPrtc := 21; opName( oPrtc ) := "prtc";
   oPrts  := 22; opName( oPrts  ) := "prts";  oPrti  := 23; opName( oPrti  ) := "prti";  oHalt := 24; opName( oHalt ) := "halt";

   nIdentifier      :=  1; ndName( nIdentifier   ) := "Identifier";   nString   :=  2; ndName( nString   ) := "String";
   nInteger         :=  3; ndName( nInteger      ) := "Integer";      nSequence :=  4; ndName( nSequence ) := "Sequence";
   nIf              :=  5; ndName( nIf           ) := "If";           nPrtc     :=  6; ndName( nPrtc     ) := "Prtc";
   nPrts            :=  7; ndName( nPrts         ) := "Prts";         nPrti     :=  8; ndName( nPrti     ) := "Prti";
   nWhile           :=  9; ndName( nWhile        ) := "While";        nAssign   := 10; ndName( nAssign   ) := "Assign";
   nNegate          := 11; ndName( nNegate       ) := "Negate";       nNot      := 12; ndName( nNot      ) := "Not";
   nMultiply        := 13; ndName( nMultiply     ) := "Multiply";     nDivide   := 14; ndName( nDivide   ) := "Divide";
   nMod             := 15; ndName( nMod          ) := "Mod";          nAdd      := 16; ndName( nAdd      ) := "Add";
   nSubtract        := 17; ndName( nSubtract     ) := "Subtract";     nLess     := 18; ndName( nLess     ) := "Less";
   nLessEqual       := 19; ndName( nLessEqual    ) := "LessEqual";    nGreater  := 20; ndName( nGreater  ) := "Greater";
   nGreaterEqual    := 21; ndName( nGreaterEqual ) := "GreaterEqual"; nEqual    := 22; ndName( nEqual    ) := "Equal";
   nNotEqual        := 23; ndName( nNotEqual     ) := "NotEqual";     nAnd      := 24; ndName( nAnd      ) := "And";
   nOr              := 25; ndName( nOr           ) := "Or";
   MAX_NODE_TYPE    := 25; TEXT_MAX := 4095; textNext := 0;
   stList := idList := null;
   for nPos := 1 until MAX_NODE_TYPE do nOp( nPos ) := -1;
   nOp( nPrtc     ) := oPrtc; nOp( nPrts      ) := oPrts; nOp( nPrti    ) := oPrti; nOp( nNegate       ) := oNeg; nOp( nNot      ) := oNot;
   nOp( nMultiply ) := oMul;  nOp( nDivide    ) := oDiv;  nOp( nMod     ) := oMod;  nOp( nAdd          ) := oAdd; nOp( nSubtract ) := oSub;
   nOp( nLess     ) := oLt;   nOp( nLessEqual ) := oLe;   nOp( nGreater ) := oGt;   nOp( nGreaterEqual ) := oGe;  nOp( nEqual    ) := oEq;
   nOp( nNotEqual ) := oNe;   nOp( nAnd       ) := oAnd;  nOp( nOr      ) := oOr;
   nextLocation     := 0; MAX_LOCATION := 4095;
   for pc := 0 until MAX_LOCATION do byteCode( pc ) := 0;
   nextLabelNumber := 0; MAX_LABEL_NUMBER := 4096;
   for lPos := 1 until MAX_LABEL_NUMBER do labelLocation( lPos ) := 0;

   % parse the output from the syntax analyser and generate code from the parse tree %
   gen( readNode );
   genOp0( oHalt );
   emitCode

end.</lang>

Output:

The While Counter example 

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

AWK

Tested with gawk 4.1.1 and mawk 1.3.4. <lang AWK> function error(msg) { 

 printf("%s\n", msg)
 exit(1)

}

function bytes_to_int(bstr, i, sum) { 

 sum = 0
 for (i=word_size-1; i>=0; i--) {
   sum *= 256
   sum += code[bstr+i]
 }
 return sum

}

function make_node(oper, left, right, value) { 

 node_type [next_free_node_index] = oper
 node_left [next_free_node_index] = left
 node_right[next_free_node_index] = right
 node_value[next_free_node_index] = value
 return next_free_node_index ++

}

function make_leaf(oper, n) { 

 return make_node(oper, 0, 0, n)

}

function emit_byte(x) { 

 code[next_free_code_index++] = x

}

function emit_word(x, i) { 

 for (i=0; i<word_size; i++) {
   emit_byte(int(x)%256);
   x = int(x/256)
 }

}

function emit_word_at(at, n, i) { 

 for (i=0; i<word_size; i++) {
   code[at+i] = int(n)%256
   n = int(n/256)
 }

}

function hole( t) { 

 t = next_free_code_index
 emit_word(0)
 return t

}

function fetch_var_offset(name, n) { 

 if (name in globals) {
   n = globals[name]
 } else {
   globals[name] = globals_n
   n = globals_n
   globals_n += 1
 }
 return n

}

function fetch_string_offset(the_string, n) { 

 n = string_pool[the_string]
 if (n == "") {
   string_pool[the_string] = string_n
   n = string_n
   string_n += 1
 }
 return n

}

function code_gen(x, n, p1, p2) { 

 if (x == 0) {
   return
 } else if (node_type[x] == "nd_Ident") {
   emit_byte(FETCH)
   n = fetch_var_offset(node_value[x])
   emit_word(n)
 } else if (node_type[x] == "nd_Integer") {
   emit_byte(PUSH)
   emit_word(node_value[x])
 } else if (node_type[x] == "nd_String") {
   emit_byte(PUSH)
   n = fetch_string_offset(node_value[x])
   emit_word(n)
 } else if (node_type[x] == "nd_Assign") {
   n = fetch_var_offset(node_value[node_left[x]])
   code_gen(node_right[x])
   emit_byte(STORE)
   emit_word(n)
 } else if (node_type[x] == "nd_If") {
   code_gen(node_left[x])        # expr
   emit_byte(JZ)                 # if false, jump
   p1 = hole()                   # make room for jump dest
   code_gen(node_left[node_right[x]])        # if true statements
   if (node_right[node_right[x]] != 0) {
     emit_byte(JMP)            # jump over else statements
     p2 = hole()
   }
   emit_word_at(p1, next_free_code_index - p1)
   if (node_right[node_right[x]] != 0) {
     code_gen(node_right[node_right[x]])   # else statements
     emit_word_at(p2, next_free_code_index - p2)
   }
 } else if (node_type[x] == "nd_While") {
   p1 =next_free_code_index
   code_gen(node_left[x])
   emit_byte(JZ)
   p2 = hole()
   code_gen(node_right[x])
   emit_byte(JMP)                       # jump back to the top
   emit_word(p1 - next_free_code_index)
   emit_word_at(p2, next_free_code_index - p2)
 } else if (node_type[x] == "nd_Sequence") {
   code_gen(node_left[x])
   code_gen(node_right[x])
 } else if (node_type[x] == "nd_Prtc") {
   code_gen(node_left[x])
   emit_byte(PRTC)
 } else if (node_type[x] == "nd_Prti") {
   code_gen(node_left[x])
   emit_byte(PRTI)
 } else if (node_type[x] == "nd_Prts") {
   code_gen(node_left[x])
   emit_byte(PRTS)
 } else if (node_type[x] in operators) {
   code_gen(node_left[x])
   code_gen(node_right[x])
   emit_byte(operators[node_type[x]])
 } else if (node_type[x] in unary_operators) {
   code_gen(node_left[x])
   emit_byte(unary_operators[node_type[x]])
 } else {
   error("error in code generator - found '" node_type[x] "', expecting operator")
 }

}

function code_finish() { 

 emit_byte(HALT)

}

function list_code() { 

 printf("Datasize: %d Strings: %d\n", globals_n, string_n)
 # Make sure that arrays are sorted by value in ascending order.
 PROCINFO["sorted_in"] =  "@val_str_asc"
 # This is a dependency on GAWK.
 for (k in string_pool)
   print(k)
 pc = 0
 while (pc < next_free_code_index) {
   printf("%4d ", pc)
   op = code[pc]
   pc += 1
   if (op == FETCH) {
     x = bytes_to_int(pc)
     printf("fetch [%d]\n", x);
     pc += word_size
   } else if (op == STORE) {
     x = bytes_to_int(pc)
     printf("store [%d]\n", x);
     pc += word_size
   } else if (op == PUSH) {
     x = bytes_to_int(pc)
     printf("push  %d\n", x);
     pc += word_size
   } else if (op == ADD)  {  print("add")
   } else if (op == SUB)  {  print("sub")
   } else if (op == MUL)  {  print("mul")
   } else if (op == DIV)  {  print("div")
   } else if (op == MOD)  {  print("mod")
   } else if (op == LT)   {  print("lt")
   } else if (op == GT)   {  print("gt")
   } else if (op == LE)   {  print("le")
   } else if (op == GE)   {  print("ge")
   } else if (op == EQ)   {  print("eq")
   } else if (op == NE)   {  print("ne")
   } else if (op == AND)  {  print("and")
   } else if (op == OR)   {  print("or")
   } else if (op == NEG)  {  print("neg")
   } else if (op == NOT)  {  print("not")
   } else if (op == JMP)  {
     x = bytes_to_int(pc)
     printf("jmp    (%d) %d\n", x, pc + x);
     pc += word_size
   } else if (op == JZ)  {
     x = bytes_to_int(pc)
     printf("jz     (%d) %d\n", x, pc + x);
     pc += word_size
   } else if (op == PRTC) { print("prtc")
   } else if (op == PRTI) { print("prti")
   } else if (op == PRTS) { print("prts")
   } else if (op == HALT) { print("halt")
   } else                 { error("list_code: Unknown opcode '" op "'")
   }
 } # while pc

}

function load_ast( line, line_list, text, n, node_type, value, left, right) { 

 getline line
 n=split(line, line_list)
 text = line_list[1]
 if (text == ";")
   return 0
 node_type = all_syms[text]
 if (n > 1) {
   value = line_list[2]
   for (i=3;i<=n;i++)
     value = value " " line_list[i]
   if (value ~ /^[0-9]+$/)
     value = int(value)
   return make_leaf(node_type, value)
 }
 left = load_ast()
 right = load_ast()
 return make_node(node_type, left, right)

}

BEGIN { 

 all_syms["Identifier"  ] = "nd_Ident"
 all_syms["String"      ] = "nd_String"
 all_syms["Integer"     ] = "nd_Integer"
 all_syms["Sequence"    ] = "nd_Sequence"
 all_syms["If"          ] = "nd_If"
 all_syms["Prtc"        ] = "nd_Prtc"
 all_syms["Prts"        ] = "nd_Prts"
 all_syms["Prti"        ] = "nd_Prti"
 all_syms["While"       ] = "nd_While"
 all_syms["Assign"      ] = "nd_Assign"
 all_syms["Negate"      ] = "nd_Negate"
 all_syms["Not"         ] = "nd_Not"
 all_syms["Multiply"    ] = "nd_Mul"
 all_syms["Divide"      ] = "nd_Div"
 all_syms["Mod"         ] = "nd_Mod"
 all_syms["Add"         ] = "nd_Add"
 all_syms["Subtract"    ] = "nd_Sub"
 all_syms["Less"        ] = "nd_Lss"
 all_syms["LessEqual"   ] = "nd_Leq"
 all_syms["Greater"     ] = "nd_Gtr"
 all_syms["GreaterEqual"] = "nd_Geq"
 all_syms["Equal"       ] = "nd_Eql"
 all_syms["NotEqual"    ] = "nd_Neq"
 all_syms["And"         ] = "nd_And"
 all_syms["Or"          ] = "nd_Or"

 FETCH=1; STORE=2; PUSH=3; ADD=4; SUB=5; MUL=6;
 DIV=7; MOD=8; LT=9; GT=10; LE=11; GE=12;
 EQ=13; NE=14; AND=15; OR=16; NEG=17; NOT=18;
 JMP=19; JZ=20; PRTC=21; PRTS=22; PRTI=23; HALT=24;

 operators["nd_Lss"] = LT
 operators["nd_Gtr"] = GT
 operators["nd_Leq"] = LE
 operators["nd_Geq"] = GE
 operators["nd_Eql"] = EQ
 operators["nd_Neq"] = NE
 operators["nd_And"] = AND
 operators["nd_Or" ] = OR
 operators["nd_Sub"] = SUB
 operators["nd_Add"] = ADD
 operators["nd_Div"] = DIV
 operators["nd_Mul"] = MUL
 operators["nd_Mod"] = MOD

 unary_operators["nd_Negate"] = NEG
 unary_operators["nd_Not"   ] = NOT

 next_free_node_index = 1
 next_free_code_index = 0
 globals_n   = 0
 string_n    = 0
 word_size   = 4
 input_file = "-"

 if (ARGC > 1)
   input_file = ARGV[1]
 n = load_ast()
 code_gen(n)
 code_finish()
 list_code()

} </lang>

Output  —  count:

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

C

Tested with gcc 4.81 and later, compiles warning free with -Wall -Wextra <lang C>#include <stdlib.h>

  1. include <stdio.h>
  2. include <string.h>
  3. include <stdarg.h>
  4. include <stdint.h>
  5. include <ctype.h>

typedef unsigned char uchar;

typedef enum { 

   nd_Ident, nd_String, nd_Integer, nd_Sequence, nd_If, nd_Prtc, nd_Prts, nd_Prti, nd_While,
   nd_Assign, nd_Negate, nd_Not, nd_Mul, nd_Div, nd_Mod, nd_Add, nd_Sub, nd_Lss, nd_Leq,
   nd_Gtr, nd_Geq, nd_Eql, nd_Neq, nd_And, nd_Or

} NodeType;

typedef enum { FETCH, STORE, PUSH, ADD, SUB, MUL, DIV, MOD, LT, GT, LE, GE, EQ, NE, AND, 

   OR, NEG, NOT, JMP, JZ, PRTC, PRTS, PRTI, HALT

} Code_t;

typedef uchar code;

typedef struct Tree { 

   NodeType node_type;
   struct Tree *left;
   struct Tree *right;
   char *value;

} Tree;

  1. define da_dim(name, type) type *name = NULL; \
                           int _qy_ ## name ## _p = 0;  \
                           int _qy_ ## name ## _max = 0
  1. define da_redim(name) do {if (_qy_ ## name ## _p >= _qy_ ## name ## _max) \
                               name = realloc(name, (_qy_ ## name ## _max += 32) * sizeof(name[0]));} while (0)
  1. define da_rewind(name) _qy_ ## name ## _p = 0
  1. define da_append(name, x) do {da_redim(name); name[_qy_ ## name ## _p++] = x;} while (0)
  2. define da_len(name) _qy_ ## name ## _p
  3. define da_add(name) do {da_redim(name); _qy_ ## name ## _p++;} while (0)

FILE *source_fp, *dest_fp; static int here; da_dim(object, code); da_dim(globals, const char *); da_dim(string_pool, const char *);

// dependency: Ordered by NodeType, must remain in same order as NodeType enum struct { 

   char       *enum_text;
   NodeType   node_type;
   Code_t     opcode;

} atr[] = { 

   {"Identifier"  , nd_Ident,    -1 },
   {"String"      , nd_String,   -1 },
   {"Integer"     , nd_Integer,  -1 },
   {"Sequence"    , nd_Sequence, -1 },
   {"If"          , nd_If,       -1 },
   {"Prtc"        , nd_Prtc,     -1 },
   {"Prts"        , nd_Prts,     -1 },
   {"Prti"        , nd_Prti,     -1 },
   {"While"       , nd_While,    -1 },
   {"Assign"      , nd_Assign,   -1 },
   {"Negate"      , nd_Negate,   NEG},
   {"Not"         , nd_Not,      NOT},
   {"Multiply"    , nd_Mul,      MUL},
   {"Divide"      , nd_Div,      DIV},
   {"Mod"         , nd_Mod,      MOD},
   {"Add"         , nd_Add,      ADD},
   {"Subtract"    , nd_Sub,      SUB},
   {"Less"        , nd_Lss,      LT },
   {"LessEqual"   , nd_Leq,      LE },
   {"Greater"     , nd_Gtr,      GT },
   {"GreaterEqual", nd_Geq,      GE },
   {"Equal"       , nd_Eql,      EQ },
   {"NotEqual"    , nd_Neq,      NE },
   {"And"         , nd_And,      AND},
   {"Or"          , nd_Or,       OR },

};

void error(const char *fmt, ... ) { 

   va_list ap;
   char buf[1000];

   va_start(ap, fmt);
   vsprintf(buf, fmt, ap);
   va_end(ap);
   printf("error: %s\n", buf);
   exit(1);

}

Code_t type_to_op(NodeType type) { 

   return atr[type].opcode;

}

Tree *make_node(NodeType node_type, Tree *left, Tree *right) { 

   Tree *t = calloc(sizeof(Tree), 1);
   t->node_type = node_type;
   t->left = left;
   t->right = right;
   return t;

}

Tree *make_leaf(NodeType node_type, char *value) { 

   Tree *t = calloc(sizeof(Tree), 1);
   t->node_type = node_type;
   t->value = strdup(value);
   return t;

}

/*** Code generator ***/

void emit_byte(int c) { 

   da_append(object, (uchar)c);
   ++here;

}

void emit_int(int32_t n) { 

   union {
       int32_t n;
       unsigned char c[sizeof(int32_t)];
   } x;

   x.n = n;

   for (size_t i = 0; i < sizeof(x.n); ++i) {
       emit_byte(x.c[i]);
   }

}

int hole() { 

   int t = here;
   emit_int(0);
   return t;

}

void fix(int src, int dst) { 

   *(int32_t *)(object + src) = dst-src;

}

int fetch_var_offset(const char *id) { 

   for (int i = 0; i < da_len(globals); ++i) {
       if (strcmp(id, globals[i]) == 0)
           return i;
   }
   da_add(globals);
   int n = da_len(globals) - 1;
   globals[n] = strdup(id);
   return n;

}

int fetch_string_offset(const char *st) { 

   for (int i = 0; i < da_len(string_pool); ++i) {
       if (strcmp(st, string_pool[i]) == 0)
           return i;
   }
   da_add(string_pool);
   int n = da_len(string_pool) - 1;
   string_pool[n] = strdup(st);
   return n;

}

void code_gen(Tree *x) { 

   int p1, p2, n;

   if (x == NULL) return;
   switch (x->node_type) {
       case nd_Ident:
           emit_byte(FETCH);
           n = fetch_var_offset(x->value);
           emit_int(n);
           break;
       case nd_Integer:
           emit_byte(PUSH);
           emit_int(atoi(x->value));
           break;
       case nd_String:
           emit_byte(PUSH);
           n = fetch_string_offset(x->value);
           emit_int(n);
           break;
       case nd_Assign:
           n = fetch_var_offset(x->left->value);
           code_gen(x->right);
           emit_byte(STORE);
           emit_int(n);
           break;
       case nd_If:
           code_gen(x->left);        // if expr
           emit_byte(JZ);                  // if false, jump
           p1 = hole();                    // make room for jump dest
           code_gen(x->right->left);   // if true statements
           if (x->right->right != NULL) {
               emit_byte(JMP);
               p2 = hole();
           }
           fix(p1, here);
           if (x->right->right != NULL) {
               code_gen(x->right->right);
               fix(p2, here);
           }
           break;
       case nd_While:
           p1 = here;
           code_gen(x->left);        // while expr
           emit_byte(JZ);                  // if false, jump
           p2 = hole();                    // make room for jump dest
           code_gen(x->right);       // statements
           emit_byte(JMP);                 // back to the top
           fix(hole(), p1);                // plug the top
           fix(p2, here);                  // plug the 'if false, jump'
           break;
       case nd_Sequence:
           code_gen(x->left);
           code_gen(x->right);
           break;
       case nd_Prtc:
           code_gen(x->left);
           emit_byte(PRTC);
           break;
       case nd_Prti:
           code_gen(x->left);
           emit_byte(PRTI);
           break;
       case nd_Prts:
           code_gen(x->left);
           emit_byte(PRTS);
           break;
       case nd_Lss: case nd_Gtr: case nd_Leq: case nd_Geq: case nd_Eql: case nd_Neq:
       case nd_And: case nd_Or: case nd_Sub: case nd_Add: case nd_Div: case nd_Mul:
       case nd_Mod:
           code_gen(x->left);
           code_gen(x->right);
           emit_byte(type_to_op(x->node_type));
           break;
       case nd_Negate: case nd_Not:
           code_gen(x->left);
           emit_byte(type_to_op(x->node_type));
           break;
       default:
           error("error in code generator - found %d, expecting operator\n", x->node_type);
   }

}

void code_finish() { 

   emit_byte(HALT);

}

void list_code() { 

   fprintf(dest_fp, "Datasize: %d Strings: %d\n", da_len(globals), da_len(string_pool));
   for (int i = 0; i < da_len(string_pool); ++i)
       fprintf(dest_fp, "%s\n", string_pool[i]);

   code *pc = object;

   again: fprintf(dest_fp, "%5d ", (int)(pc - object));
   switch (*pc++) {
       case FETCH: fprintf(dest_fp, "fetch [%d]\n", *(int32_t *)pc);
                   pc += sizeof(int32_t);  goto again;
       case STORE: fprintf(dest_fp, "store [%d]\n", *(int32_t *)pc);
                   pc += sizeof(int32_t);  goto again;
       case PUSH : fprintf(dest_fp, "push  %d\n", *(int32_t *)pc);
                   pc += sizeof(int32_t);    goto again;
       case ADD  : fprintf(dest_fp, "add\n");      goto again;
       case SUB  : fprintf(dest_fp, "sub\n");      goto again;
       case MUL  : fprintf(dest_fp, "mul\n");      goto again;
       case DIV  : fprintf(dest_fp, "div\n");      goto again;
       case MOD  : fprintf(dest_fp, "mod\n");      goto again;
       case LT   : fprintf(dest_fp, "lt\n");       goto again;
       case GT   : fprintf(dest_fp, "gt\n");       goto again;
       case LE   : fprintf(dest_fp, "le\n");       goto again;
       case GE   : fprintf(dest_fp, "ge\n");       goto again;
       case EQ   : fprintf(dest_fp, "eq\n");       goto again;
       case NE   : fprintf(dest_fp, "ne\n");       goto again;
       case AND  : fprintf(dest_fp, "and\n");      goto again;
       case OR   : fprintf(dest_fp, "or\n");       goto again;
       case NOT  : fprintf(dest_fp, "not\n");      goto again;
       case NEG  : fprintf(dest_fp, "neg\n");      goto again;
       case JMP  : fprintf(dest_fp, "jmp    (%d) %d\n",
                       *(int32_t *)pc, (int32_t)(pc + *(int32_t *)pc - object));
                   pc += sizeof(int32_t); goto again;
       case JZ   : fprintf(dest_fp, "jz     (%d) %d\n",
                       *(int32_t *)pc, (int32_t)(pc + *(int32_t *)pc - object));
                   pc += sizeof(int32_t); goto again;
       case PRTC : fprintf(dest_fp, "prtc\n");     goto again;
       case PRTI : fprintf(dest_fp, "prti\n");     goto again;
       case PRTS : fprintf(dest_fp, "prts\n");     goto again;
       case HALT : fprintf(dest_fp, "halt\n");     break;
       default:error("listcode:Unknown opcode %d\n", *(pc - 1));
   }

}

void init_io(FILE **fp, FILE *std, const char mode[], const char fn[]) { 

   if (fn[0] == '\0')
       *fp = std;
   else if ((*fp = fopen(fn, mode)) == NULL)
       error(0, 0, "Can't open %s\n", fn);

}

NodeType get_enum_value(const char name[]) { 

   for (size_t i = 0; i < sizeof(atr) / sizeof(atr[0]); i++) {
       if (strcmp(atr[i].enum_text, name) == 0) {
           return atr[i].node_type;
       }
   }
   error("Unknown token %s\n", name);
   return -1;

}

char *read_line(int *len) { 

   static char *text = NULL;
   static int textmax = 0;

   for (*len = 0; ; (*len)++) {
       int ch = fgetc(source_fp);
       if (ch == EOF || ch == '\n') {
           if (*len == 0)
               return NULL;
           break;
       }
       if (*len + 1 >= textmax) {
           textmax = (textmax == 0 ? 128 : textmax * 2);
           text = realloc(text, textmax);
       }
       text[*len] = ch;
   }
   text[*len] = '\0';
   return text;

}

char *rtrim(char *text, int *len) { // remove trailing spaces 

   for (; *len > 0 && isspace(text[*len - 1]); --(*len))
       ;

   text[*len] = '\0';
   return text;

}

Tree *load_ast() { 

   int len;
   char *yytext = read_line(&len);
   yytext = rtrim(yytext, &len);

   // get first token
   char *tok = strtok(yytext, " ");

   if (tok[0] == ';') {
       return NULL;
   }
   NodeType node_type = get_enum_value(tok);

   // if there is extra data, get it
   char *p = tok + strlen(tok);
   if (p != &yytext[len]) {
       for (++p; isspace(*p); ++p)
           ;
       return make_leaf(node_type, p);
   }

   Tree *left  = load_ast();
   Tree *right = load_ast();
   return make_node(node_type, left, right);

}

int main(int argc, char *argv[]) { 

   init_io(&source_fp, stdin,  "r",  argc > 1 ? argv[1] : "");
   init_io(&dest_fp,   stdout, "wb", argc > 2 ? argv[2] : "");

   code_gen(load_ast());
   code_finish();
   list_code();

   return 0;

}</lang>

Output  —  While counter example:

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

COBOL

Code by Steve Williams. Tested with GnuCOBOL 2.2.

<lang cobol> >>SOURCE FORMAT IS FREE identification division.

  • > this code is dedicated to the public domain
  • > (GnuCOBOL) 2.3-dev.0

program-id. generator. environment division. configuration section. repository. function all intrinsic. data division. working-storage section. 01 program-name pic x(32) value spaces global. 01 input-name pic x(32) value spaces global. 01 input-status pic xx global.

01 ast-record global. 

   03  ast-type pic x(14).
   03  ast-value pic x(48).
   03  filler redefines ast-value.
       05  asl-left pic 999.
       05  asl-right pic 999.

01 error-record pic x(64) value spaces global.

01 loadstack global. 

   03  l pic 99 value 0.
   03  l-lim pic 99 value 64.
   03  load-entry occurs 64.
       05  l-node pic x(14).
       05  l-left pic 999.
       05  l-right pic 999.
       05  l-link pic 999.

01 abstract-syntax-tree global. 

   03  t pic 999 value 0.
   03  t1 pic 999.
   03  t-lim pic 999 value 998.
   03  filler occurs 998.
       05  p1 pic 999.
       05  p2 pic 999.
       05  p3 pic 999.
       05  n1 pic 999.
       05  leaf.
           07  leaf-type pic x(14).
           07  leaf-value pic x(48).
       05  node redefines leaf.
           07  node-type pic x(14).
           07  node-left pic 999.
           07  node-right pic 999.

01 opcodes global. 

   03  opFETCH pic x value x'00'.
   03  opSTORE pic x value x'01'.
   03  opPUSH  pic x value x'02'.
   03  opADD   pic x value x'03'.
   03  opSUB   pic x value x'04'.
   03  opMUL   pic x value x'05'.
   03  opDIV   pic x value x'06'.
   03  opMOD   pic x value x'07'.
   03  opLT    pic x value x'08'.
   03  opGT    pic x value x'09'.
   03  opLE    pic x value x'0A'.
   03  opGE    pic x value x'0B'.
   03  opEQ    pic x value x'0C'.
   03  opNE    pic x value x'0D'.
   03  opAND   pic x value x'0E'.
   03  opOR    pic x value x'0F'.
   03  opNEG   pic x value x'10'.
   03  opNOT   pic x value x'11'.
   03  opJMP   pic x value x'13'.
   03  opJZ    pic x value x'14'.
   03  opPRTC  pic x value x'15'.
   03  opPRTS  pic x value x'16'.
   03  opPRTI  pic x value x'17'.
   03  opHALT  pic x value x'18'.

01 variables global. 

   03  v pic 99.
   03  v-max pic 99 value 0.
   03  v-lim pic 99 value 16.
   03  variable-entry occurs 16 pic x(48).

01 strings global. 

   03  s pic 99.
   03  s-max pic 99 value 0.
   03  s-lim pic 99 value 16.
   03  string-entry occurs 16 pic x(48).

01 generated-code global. 

   03  c  pic 999 value 1.
   03  c1 pic 999.
   03  c-lim pic 999 value 512.
   03  kode pic x(512).

procedure division chaining program-name. start-generator. 

   call 'loadast'
   if program-name <> spaces
       call 'readinput' *> close input-file
   end-if
   >>d perform print-ast
   call 'codegen' using t
   call 'emitbyte' using opHALT
   >>d call 'showhex' using kode c
   call 'listcode'
   stop run
   .

print-ast. 

   call 'printast' using t
   display 'ast:' upon syserr
   display 't=' t
   perform varying t1 from 1 by 1 until t1 > t
       if leaf-type(t1) = 'Identifier' or 'Integer' or 'String'
           display t1 space trim(leaf-type(t1)) space trim(leaf-value(t1)) upon syserr
       else
           display t1 space node-left(t1) space node-right(t1) space trim(node-type(t1)) 
               upon syserr
       end-if
   end-perform
   .

identification division. program-id. codegen common recursive. data division. working-storage section. 01 r pic ---9. linkage section. 01 n pic 999. procedure division using n. start-codegen. 

   if n = 0
       exit program
   end-if
   >>d display 'at 'c ' node=' space n space node-type(n) upon syserr
   evaluate node-type(n)
   when 'Identifier'
       call 'emitbyte' using opFetch
       call 'variableoffset' using leaf-value(n)
       call 'emitword' using v '0'
   when 'Integer'
       call 'emitbyte' using opPUSH
       call 'emitword' using leaf-value(n) '0'
   when 'String'
       call 'emitbyte' using opPUSH
       call 'stringoffset' using leaf-value(n)
       call 'emitword' using s '0'
   when 'Assign'
       call 'codegen' using node-right(n)
       call 'emitbyte' using opSTORE
       move node-left(n) to n1(n)
       call 'variableoffset' using leaf-value(n1(n))
       call 'emitword' using v '0'
   when 'If'
       call 'codegen' using node-left(n)          *> conditional expr
       call 'emitbyte' using opJZ                 *> jump to false path or exit
       move c to p1(n)                      
       call 'emitword' using '0' '0'
       move node-right(n) to n1(n)                *> true path
       call 'codegen' using node-left(n1(n))
       if node-right(n1(n)) <> 0                  *> there is a false path
           call 'emitbyte' using opJMP            *> jump past false path
           move c to p2(n)                 
           call 'emitword' using '0' '0'
           compute r = c - p1(n)                  *> fill in jump to false path
           call 'emitword' using r p1(n)
           call 'codegen' using node-right(n1(n)) *> false path
           compute r = c - p2(n)                  *> fill in jump to exit
           call 'emitword' using r p2(n)
       else
           compute r = c - p1(n)
           call 'emitword' using r p1(n)          *> fill in jump to exit
       end-if
   when 'While'
       move c to p3(n)                            *> save address of while start
       call 'codegen' using node-left(n)          *> conditional expr
       call 'emitbyte' using opJZ                 *> jump to exit
       move c to p2(n)
       call 'emitword' using '0' '0'
       call 'codegen' using node-right(n)         *> while body
       call 'emitbyte' using opJMP                *> jump to while start
       compute r = p3(n) - c
       call 'emitword' using r '0'
       compute r = c - p2(n)                      *> fill in jump to exit
       call 'emitword' using r p2(n)
   when 'Sequence'
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
   when 'Prtc'
       call 'codegen' using node-left(n)
       call 'emitbyte' using opPRTC
   when 'Prti'
       call 'codegen' using node-left(n)
       call 'emitbyte' using opPRTI
   when 'Prts'
       call 'codegen' using node-left(n)
       call 'emitbyte' using opPRTS
   when 'Less'
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
       call 'emitbyte' using opLT
   when 'Greater'
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
       call 'emitbyte' using opGT
   when 'LessEqual'
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
       call 'emitbyte' using opLE
   when 'GreaterEqual'
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
       call 'emitbyte' using opGE
   when 'Equal'
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
       call 'emitbyte' using opEQ
   when 'NotEqual'
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
       call 'emitbyte' using opNE
   when 'And'
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
       call 'emitbyte' using opAND
   when 'Or'
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
       call 'emitbyte' using opOR
   when 'Subtract'
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
       call 'emitbyte' using opSUB
   when 'Add'
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
       call 'emitbyte' using opADD
   when 'Divide'
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
       call 'emitbyte' using opDIV
   when 'Multiply'
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
       call 'emitbyte' using opMUL
   when 'Mod' 
       call 'codegen' using node-left(n)
       call 'codegen' using node-right(n)
       call 'emitbyte' using opMOD
   when 'Negate'
      call 'codegen' using node-left(n)
      call 'emitbyte' using opNEG
   when 'Not' 
       call 'codegen' using node-left(n)
       call 'emitbyte' using opNOT
   when other
       string 'in generator unknown node type: ' node-type(n) into error-record
       call 'reporterror'
   end-evaluate
   .

end program codegen.

identification division. program-id. variableoffset common. data division. linkage section. 01 variable-value pic x(48). procedure division using variable-value. start-variableoffset. 

   perform varying v from 1 by 1
   until v > v-max
   or variable-entry(v) = variable-value
       continue
   end-perform
   if v > v-lim
       string 'in generator variable offset v exceeds ' v-lim into error-record
       call 'reporterror'
   end-if
   if v > v-max
       move v to v-max
       move variable-value to variable-entry(v)
   end-if
   .

end program variableoffset.

identification division. program-id. stringoffset common. data division. linkage section. 01 string-value pic x(48). procedure division using string-value. start-stringoffset. 

   perform varying s from 1 by 1
   until s > s-max
   or string-entry(s) = string-value
       continue
   end-perform
   if s > s-lim
       string ' generator stringoffset s exceeds ' s-lim into error-record
       call 'reporterror'
   end-if
   if s > s-max
       move s to s-max
       move string-value to string-entry(s)
   end-if
   subtract 1 from s *> convert index to offset
   .

end program stringoffset.

identification division. program-id. emitbyte common. data division. linkage section. 01 opcode pic x. procedure division using opcode. start-emitbyte. 

   if c >= c-lim
       string 'in generator emitbyte c exceeds ' c-lim into error-record
       call 'reporterror'
   end-if
   move opcode to kode(c:1)
   add 1 to c
   .

end program emitbyte.

identification division. program-id. emitword common. data division. working-storage section. 01 word-x. 

   03  word usage binary-int.

01 loc pic 999. linkage section. 01 word-value any length. 01 loc-value any length. procedure division using word-value loc-value. start-emitword. 

   if c + length(word) > c-lim
       string 'in generator emitword exceeds ' c-lim into error-record
       call 'reporterror'
   end-if
   move numval(word-value) to word
   move numval(loc-value) to loc
   if loc = 0
       move word-x to kode(c:length(word))
       add length(word) to c
   else
       move word-x to kode(loc:length(word))
   end-if
   .

end program emitword.

identification division. program-id. listcode common. data division. working-storage section. 01 word-x. 

   03  word usage binary-int.

01 address-display pic ---9. 01 address-absolute pic zzz9. 01 data-display pic -(9)9. 01 v-display pic z9. 01 s-display pic z9. 01 c-display pic zzz9. procedure division. start-listcode. 

   move v-max to v-display
   move s-max to s-display
   display 'Datasize: ' trim(v-display) space 'Strings: ' trim(s-display)

   perform varying s from 1 by 1
   until s > s-max
       display string-entry(s)
   end-perform 

   move 1 to c1
   perform until c1 >= c
       compute c-display = c1 - 1
       display c-display space with no advancing
       evaluate kode(c1:1)
       when opFETCH
           add 1 to c1
           move kode(c1:4) to word-x
           compute address-display = word - 1 
           display 'fetch [' trim(address-display) ']'
           add 3 to c1
       when opSTORE
           add 1 to c1
           move kode(c1:4) to word-x
           compute address-display = word - 1
           display 'store [' trim(address-display) ']'
           add 3 to c1
       when opPUSH
           add 1 to c1
           move kode(c1:4) to word-x
           move word to data-display
           display 'push  ' trim(data-display)
           add 3 to c1
       when opADD   display 'add'
       when opSUB   display 'sub'
       when opMUL   display 'mul'
       when opDIV   display 'div'
       when opMOD   display 'mod'
       when opLT    display 'lt'
       when opGT    display 'gt'
       when opLE    display 'le'
       when opGE    display 'ge'
       when opEQ    display 'eq'
       when opNE    display 'ne'
       when opAND   display 'and'
       when opOR    display 'or'
       when opNEG   display 'neg'
       when opNOT   display 'not'
       when opJMP
           move kode(c1 + 1:length(word)) to word-x
           move word to address-display
           compute address-absolute = c1 + word
           display 'jmp    (' trim(address-display) ') ' trim(address-absolute)
           add length(word) to c1
       when opJZ
           move kode(c1 + 1:length(word)) to word-x
           move word to address-display
           compute address-absolute = c1 + word
           display 'jz     (' trim(address-display) ') ' trim(address-absolute)
           add length(word) to c1
       when opPRTC  display 'prtc'
       when opPRTI  display 'prti'
       when opPRTS  display 'prts'
       when opHALT  display 'halt'
       when other
           string 'in generator unknown opcode ' kode(c1:1) into error-record
           call 'reporterror'
       end-evaluate
       add 1 to c1
   end-perform
   .

end program listcode.

identification division. program-id. loadast common recursive. procedure division. start-loadast. 

   if l >= l-lim
       string 'in generator loadast l exceeds ' l-lim into error-record
       call 'reporterror'
   end-if
   add 1 to l
   call 'readinput'
   evaluate true
   when ast-record = ';'
   when input-status = '10'
       move 0 to return-code
   when ast-type = 'Identifier'
   when ast-type = 'Integer'
   when ast-type = 'String'
       call 'makeleaf' using ast-type ast-value
       move t to return-code
   when ast-type = 'Sequence'
       move ast-type to l-node(l)
       call 'loadast'
       move return-code to l-left(l)
       call 'loadast'
       move t to l-right(l)
       call 'makenode' using l-node(l) l-left(l) l-right(l)
       move t to return-code
   when other
       move ast-type to l-node(l)
       call 'loadast'
       move return-code to l-left(l)
       call 'loadast'
       move return-code to l-right(l)
       call 'makenode' using l-node(l) l-left(l) l-right(l)
       move t to return-code
   end-evaluate
   subtract 1 from l
   .

end program loadast.

identification division. program-id. printast common recursive. data division. linkage section. 01 n pic 999. procedure division using n. start-printast. 

   if n = 0
       display ';' upon syserr
       exit program
   end-if
   display leaf-type(n) upon syserr
   evaluate leaf-type(n)
   when 'Identifier'
   when 'Integer'
   when 'String'
       display leaf-type(n) space trim(leaf-value(n)) upon syserr
   when other
       display node-type(n) upon syserr
       call 'printast' using node-left(n)
       call 'printast' using node-right(n)
   end-evaluate
   .

end program printast.

identification division. program-id. makenode common. data division. linkage section. 01 parm-type any length. 01 parm-l-left pic 999. 01 parm-l-right pic 999. procedure division using parm-type parm-l-left parm-l-right. start-makenode. 

   if t >= t-lim 
       string 'in generator makenode t exceeds ' t-lim into error-record
       call 'reporterror'
   end-if
   add 1 to t
   move parm-type to node-type(t)
   move parm-l-left to node-left(t)
   move parm-l-right to node-right(t)
   .

end program makenode.

identification division. program-id. makeleaf common. data division. linkage section. 01 parm-type any length. 01 parm-value pic x(48). procedure division using parm-type parm-value. start-makeleaf. 

   add 1 to t
   if t >= t-lim 
       string 'in generator makeleaf t exceeds ' t-lim into error-record
       call 'reporterror'
   end-if
   move parm-type to leaf-type(t)
   move parm-value to leaf-value(t)
   .

end program makeleaf.

identification division. program-id. readinput common. environment division. input-output section. file-control. 

   select input-file assign using input-name
       status is input-status
       organization is line sequential.

data division. file section. fd input-file. 01 input-record pic x(64). procedure division. start-readinput. 

   if program-name = spaces
       move '00' to input-status
       accept ast-record on exception move '10' to input-status end-accept
       exit program
   end-if
   if input-name = spaces
       string program-name delimited by space '.ast' into input-name
       open input input-file
       if input-status = '35'
           string 'in generator ' trim(input-name) ' not found' into error-record
           call 'reporterror'
       end-if
   end-if
   read input-file into ast-record
   evaluate input-status
   when '00'
       continue
   when '10'
       close input-file
   when other
       string 'in generator ' trim(input-name) ' unexpected input-status: ' input-status
           into error-record
       call 'reporterror'
   end-evaluate
   .

end program readinput.

program-id. reporterror common. procedure division. start-reporterror. report-error. 

   display error-record upon syserr
   stop run with error status -1
   .

end program reporterror.

identification division. program-id. showhex common.

data division. working-storage section. 01 hex. 

   03  filler pic x(32) value '000102030405060708090A0B0C0D0E0F'.
   03  filler pic x(32) value '101112131415161718191A1B1C1D1E1F'.
   03  filler pic x(32) value '202122232425262728292A2B2C2D2E2F'.
   03  filler pic x(32) value '303132333435363738393A3B3C3D3E3F'.
   03  filler pic x(32) value '404142434445464748494A4B4C4D4E4F'.
   03  filler pic x(32) value '505152535455565758595A5B5C5D5E5F'.
   03  filler pic x(32) value '606162636465666768696A6B6C6D6E6F'.
   03  filler pic x(32) value '707172737475767778797A7B7C7D7E7F'.
   03  filler pic x(32) value '808182838485868788898A8B8C8D8E8F'.
   03  filler pic x(32) value '909192939495969798999A9B9C9D9E9F'.
   03  filler pic x(32) value 'A0A1A2A3A4A5A6A7A8A9AAABACADAEAF'.
   03  filler pic x(32) value 'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF'.
   03  filler pic x(32) value 'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF'.
   03  filler pic x(32) value 'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF'.
   03  filler pic x(32) value 'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF'.
   03  filler pic x(32) value 'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF'.

01 cdx pic 9999. 01 bdx pic 999. 01 byte-count pic 9. 01 bytes-per-word pic 9 value 4. 01 word-count pic 9. 01 words-per-line pic 9 value 8.

linkage section. 01 data-field any length. 01 length-data-field pic 999.

procedure division using 

   by reference data-field
   by reference length-data-field.

start-showhex. 

   move 1 to byte-count
   move 1 to word-count
   perform varying cdx from 1 by 1
   until cdx > length-data-field
        compute bdx = 2 * ord(data-field(cdx:1)) - 1 end-compute
        display hex(bdx:2) with no advancing upon syserr
        add 1 to byte-count end-add
        if byte-count > bytes-per-word
            display ' ' with no advancing upon syserr
            move 1 to byte-count
            add 1 to word-count end-add
        end-if
        if word-count > words-per-line
            display ' ' upon syserr
            move 1 to word-count
        end-if
   end-perform
   if word-count <> 1
   or byte-count <> 1
       display ' ' upon syserr
   end-if
   display ' ' upon syserr
   goback
   .

end program showhex. end program generator.</lang>

Output  —  Count:
prompt$ ./lexer <testcases/Count | ./parser | ./generator 
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

Forth

Tested with Gforth 0.7.3 <lang Forth>CREATE BUF 0 ,

PEEK BUF @ 0= IF KEY BUF ! THEN BUF @ ;
GETC PEEK 0 BUF ! ;
SPACE? DUP BL = SWAP 9 14 WITHIN OR ;
>SPACE BEGIN PEEK SPACE? WHILE GETC DROP REPEAT ;
DIGIT? 48 58 WITHIN ;
>Integer >SPACE 0
  BEGIN  PEEK DIGIT?
  WHILE  GETC [CHAR] 0 -  SWAP 10 * +  REPEAT ;
SKIP ( xt --)
  BEGIN PEEK OVER EXECUTE WHILE GETC DROP REPEAT DROP ;
WORD ( xt -- c-addr) DUP >R SKIP PAD 1+
  BEGIN PEEK R@ EXECUTE INVERT
  WHILE GETC OVER C! CHAR+
  REPEAT  R> SKIP  PAD TUCK - 1-  PAD C! ;
INTERN ( c-addr -- c-addr)
  HERE TUCK OVER C@ CHAR+ DUP ALLOT CMOVE ;
"? [CHAR] " = ;
"TYPE" [CHAR] " EMIT TYPE [CHAR] " EMIT ;
. 0 .R ;
3@ ( addr -- w3 w2 w1)
  [ 2 CELLS ]L + DUP @ SWAP CELL - DUP @ SWAP CELL - @ ;

CREATE BUF' 12 ALLOT

PREPEND ( c-addr c -- c-addr) BUF' 1+ C!
  COUNT 10 MIN DUP 1+ BUF' C!  BUF' 2 + SWAP CMOVE  BUF' ;
>NODE ( c-addr -- n) [CHAR] $ PREPEND FIND
  IF EXECUTE ELSE ." unrecognized node " COUNT TYPE CR THEN ;
NODE ( n left right -- addr) HERE >R , , , R> ;
CONS ( a b l -- l) HERE >R , , , R> ;
FIRST ( l -- a) [ 2 CELLS ]L + @ ;
SECOND ( l -- b) CELL+ @ ;
C=? ( c-addr1 c-addr2 -- t|f) COUNT ROT COUNT COMPARE 0= ;
LOOKUP ( c-addr l -- n t | c-addr f)
  BEGIN DUP WHILE OVER OVER FIRST C=?
    IF NIP SECOND TRUE EXIT THEN  @
  REPEAT  DROP FALSE ;

CREATE GLOBALS 0 , CREATE STRINGS 0 ,

DEPTH ( pool -- n) DUP IF SECOND 1+ THEN ;
FISH ( c-addr pool -- n pool') TUCK LOOKUP IF SWAP
  ELSE INTERN OVER DEPTH ROT OVER >R CONS  R> SWAP THEN ;
>Identifier ['] SPACE? WORD GLOBALS @ FISH GLOBALS ! ;
>String ['] "? WORD STRINGS @ FISH STRINGS ! ;
>; 0 ;
HANDLER [CHAR] @ PREPEND FIND DROP ;
READER ( c-addr -- xt t | f)
  [CHAR] > PREPEND  FIND  DUP 0= IF NIP THEN ;

DEFER GETAST

READ ( c-addr -- right left) READER
  IF EXECUTE 0 ELSE GETAST GETAST THEN SWAP ;
(GETAST) ['] SPACE? WORD DUP HANDLER >R READ R> NODE ;

' (GETAST) IS GETAST

CREATE PC 0 ,

i32! ( n addr --)
  OVER           $FF AND OVER C! 1+
  OVER  8 RSHIFT $FF AND OVER C! 1+
  OVER 16 RSHIFT $FF AND OVER C! 1+
  OVER 24 RSHIFT $FF AND OVER C!    DROP DROP ;
i32, ( n --) HERE i32! 4 ALLOT 4 PC +! ;
i8, ( c --) C, 1 PC +! ;
i8@+ DUP 1+ SWAP C@ 1 PC +! ;
i32@+ ( addr -- addr+4 n)
  i8@+                 >R  i8@+  8 LSHIFT R> OR >R
  i8@+ 16 LSHIFT R> OR >R  i8@+ 24 LSHIFT R> OR ;

CREATE #OPS 0 ,

OP: CREATE #OPS @ , 1 #OPS +! DOES> @ ;

OP: fetch OP: store OP: push OP: jmp OP: jz OP: prtc OP: prti OP: prts OP: neg OP: not OP: add OP: sub OP: mul OP: div OP: mod OP: lt OP: gt OP: le OP: ge OP: eq OP: ne OP: and OP: or OP: halt

GEN ( ast --) 3@ EXECUTE ;
@; ( r l) DROP DROP ;
@Identifier fetch i8, i32, DROP ;
@Integer push i8, i32, DROP ;
@String push i8, i32, DROP ;
@Prtc GEN prtc i8, DROP ;
@Prti GEN prti i8, DROP ;
@Prts GEN prts i8, DROP ;
@Not GEN not i8, DROP ;
@Negate GEN neg i8, DROP ;
@Sequence GEN GEN ;
@Assign CELL+ @ >R GEN store i8, R> i32, ;
@While PC @ SWAP GEN jz i8, HERE >R 0 i32,
  SWAP GEN  jmp i8, i32,  PC @ R> i32! ;
@If GEN jz i8, HERE >R 0 i32,
  CELL+ DUP CELL+ @ DUP @ ['] @; = IF DROP @
  ELSE SWAP @ GEN  jmp i8, HERE 0 i32,  PC @ R> i32!  >R
  THEN  GEN PC @ R> i32! ;
BINARY >R GEN GEN R> i8, ;
@Subtract sub BINARY ;  : @Add add BINARY ;
@Mod mod BINARY ;  : @Multiply mul BINARY ;
@Divide div BINARY ;
@Less lt BINARY ;  : @LessEqual le BINARY ;
@Greater gt BINARY ;  : @GreaterEqual ge BINARY ;
@Equal eq BINARY ;  : @NotEqual ne BINARY ;
@And and BINARY ;  : @Or or BINARY ;
REVERSE ( l -- l') 0 SWAP
  BEGIN DUP WHILE TUCK DUP @  ROT ROT  ! REPEAT  DROP ;
.STRINGS STRINGS @ REVERSE BEGIN DUP
  WHILE DUP FIRST COUNT "TYPE" CR @ REPEAT DROP ;
.HEADER ( --)
  ." Datasize: " GLOBALS @ DEPTH . SPACE
  ." Strings: "  STRINGS @ DEPTH . CR  .STRINGS ;
GENERATE ( ast -- addr u)
  0 PC ! HERE >R  GEN halt i8,  R> PC @ ;
," [CHAR] " PARSE TUCK HERE SWAP CMOVE ALLOT ;

CREATE "OPS" ," fetch store push jmp jz prtc prti prts " ," neg not add sub mul div mod lt " ," gt le ge eq ne and or halt "

.i32 i32@+ . ;
.[i32] [CHAR] [ EMIT .i32 [CHAR] ] EMIT ;
.off [CHAR] ( EMIT PC @ >R i32@+ DUP R> - . [CHAR] ) EMIT
   SPACE . ;

CREATE .INT ' .[i32] , ' .[i32] , ' .i32 , ' .off , ' .off ,

EMIT ( addr u --) >R 0 PC !
  BEGIN PC @ R@ <
  WHILE PC @ 5 .R SPACE  i8@+
    DUP 6 * "OPS" + 6 TYPE
    DUP 5 < IF CELLS .INT + @ EXECUTE ELSE DROP THEN CR
  REPEAT DROP R> DROP ;

GENERATE EMIT BYE</lang> Passes all tests.

Fortran

Works with: gfortran version 11.2.1

Fortran 2008/2018 code with C preprocessing. On case-sensitive systems, if you call the source file gen.F90, with a capital F, then gfortran will know to use the C preprocessor.

<lang fortran>module compiler_type_kinds 

 use, intrinsic :: iso_fortran_env, only: int32
 use, intrinsic :: iso_fortran_env, only: int64

 implicit none
 private

 ! Synonyms.
 integer, parameter, public :: size_kind = int64
 integer, parameter, public :: length_kind = size_kind
 integer, parameter, public :: nk = size_kind

 ! Synonyms for character capable of storing a Unicode code point.
 integer, parameter, public :: unicode_char_kind = selected_char_kind ('ISO_10646')
 integer, parameter, public :: ck = unicode_char_kind

 ! Synonyms for integers capable of storing a Unicode code point.
 integer, parameter, public :: unicode_ichar_kind = int32
 integer, parameter, public :: ick = unicode_ichar_kind

 ! Synonyms for integers in the virtual machine or the interpreter’s
 ! runtime. (The Rosetta Code task says integers in the virtual
 ! machine are 32-bit, but there is nothing in the task that prevents
 ! us using 64-bit integers in the compiler and interpreter.)
 integer, parameter, public :: runtime_int_kind = int64
 integer, parameter, public :: rik = runtime_int_kind

end module compiler_type_kinds

module helper_procedures 

 use, non_intrinsic :: compiler_type_kinds, only: nk, rik, ck

 implicit none
 private

 public :: new_storage_size
 public :: next_power_of_two

 public :: isspace
 public :: quoted_string

 public :: int32_to_vm_bytes
 public :: uint32_to_vm_bytes
 public :: int32_from_vm_bytes
 public :: uint32_from_vm_bytes

 character(1, kind = ck), parameter :: horizontal_tab_char = char (9, kind = ck)
 character(1, kind = ck), parameter :: linefeed_char = char (10, kind = ck)
 character(1, kind = ck), parameter :: vertical_tab_char = char (11, kind = ck)
 character(1, kind = ck), parameter :: formfeed_char = char (12, kind = ck)
 character(1, kind = ck), parameter :: carriage_return_char = char (13, kind = ck)
 character(1, kind = ck), parameter :: space_char = ck_' '

 ! The following is correct for Unix and its relatives.
 character(1, kind = ck), parameter :: newline_char = linefeed_char

 character(1, kind = ck), parameter :: backslash_char = char (92, kind = ck)

contains 

 elemental function new_storage_size (length_needed) result (size)
   integer(kind = nk), intent(in) :: length_needed
   integer(kind = nk) :: size

   ! Increase storage by orders of magnitude.

   if (2_nk**32 < length_needed) then
      size = huge (1_nk)
   else
      size = next_power_of_two (length_needed)
   end if
 end function new_storage_size

 elemental function next_power_of_two (x) result (y)
   integer(kind = nk), intent(in) :: x
   integer(kind = nk) :: y

   !
   ! It is assumed that no more than 64 bits are used.
   !
   ! The branch-free algorithm is that of
   ! https://archive.is/nKxAc#RoundUpPowerOf2
   !
   ! Fill in bits until one less than the desired power of two is
   ! reached, and then add one.
   !

   y = x - 1
   y = ior (y, ishft (y, -1))
   y = ior (y, ishft (y, -2))
   y = ior (y, ishft (y, -4))
   y = ior (y, ishft (y, -8))
   y = ior (y, ishft (y, -16))
   y = ior (y, ishft (y, -32))
   y = y + 1
 end function next_power_of_two

 elemental function isspace (ch) result (bool)
   character(1, kind = ck), intent(in) :: ch
   logical :: bool

   bool = (ch == horizontal_tab_char) .or.  &
        & (ch == linefeed_char) .or.        &
        & (ch == vertical_tab_char) .or.    &
        & (ch == formfeed_char) .or.        &
        & (ch == carriage_return_char) .or. &
        & (ch == space_char)
 end function isspace

 function quoted_string (str) result (qstr)
   character(*, kind = ck), intent(in) :: str
   character(:, kind = ck), allocatable :: qstr

   integer(kind = nk) :: n, i, j

   ! Compute n = the size of qstr.
   n = 2_nk
   do i = 1_nk, len (str, kind = nk)
      select case (str(i:i))
      case (newline_char, backslash_char)
         n = n + 2
      case default
         n = n + 1
      end select
   end do

   allocate (character(n, kind = ck) :: qstr)

   ! Quote the string.
   qstr(1:1) = ck_'"'
   j = 2_nk
   do i = 1_nk, len (str, kind = nk)
      select case (str(i:i))
      case (newline_char)
         qstr(j:j) = backslash_char
         qstr((j + 1):(j + 1)) = ck_'n'
         j = j + 2
      case (backslash_char)
         qstr(j:j) = backslash_char
         qstr((j + 1):(j + 1)) = backslash_char
         j = j + 2
      case default
         qstr(j:j) = str(i:i)
         j = j + 1
      end select
   end do
   if (j /= n) error stop      ! Check code correctness.
   qstr(n:n) = ck_'"'
 end function quoted_string

 subroutine int32_to_vm_bytes (n, bytes, i)
   integer(kind = rik), intent(in) :: n
   character(1), intent(inout) :: bytes(0:*)
   integer(kind = rik), intent(in) :: i

   !
   ! The virtual machine is presumed to be little-endian. Because I
   ! slightly prefer little-endian.
   !

   bytes(i) = achar (ibits (n, 0, 8))
   bytes(i + 1) = achar (ibits (n, 8, 8))
   bytes(i + 2) = achar (ibits (n, 16, 8))
   bytes(i + 3) = achar (ibits (n, 24, 8))
 end subroutine int32_to_vm_bytes

 subroutine uint32_to_vm_bytes (n, bytes, i)
   integer(kind = rik), intent(in) :: n
   character(1), intent(inout) :: bytes(0:*)
   integer(kind = rik), intent(in) :: i

   call int32_to_vm_bytes (n, bytes, i)
 end subroutine uint32_to_vm_bytes

 subroutine int32_from_vm_bytes (n, bytes, i)
   integer(kind = rik), intent(out) :: n
   character(1), intent(in) :: bytes(0:*)
   integer(kind = rik), intent(in) :: i

   !
   ! The virtual machine is presumed to be little-endian. Because I
   ! slightly prefer little-endian.
   !

   call uint32_from_vm_bytes (n, bytes, i)
   if (ibits (n, 31, 1) == 1) then
      ! Extend the sign bit.
      n = ior (n, not ((2_rik ** 32) - 1))
   end if
 end subroutine int32_from_vm_bytes

 subroutine uint32_from_vm_bytes (n, bytes, i)
   integer(kind = rik), intent(out) :: n
   character(1), intent(in) :: bytes(0:*)
   integer(kind = rik), intent(in) :: i

   !
   ! The virtual machine is presumed to be little-endian. Because I
   ! slightly prefer little-endian.
   !

   integer(kind = rik) :: n0, n1, n2, n3

   n0 = iachar (bytes(i), kind = rik)
   n1 = ishft (iachar (bytes(i + 1), kind = rik), 8)
   n2 = ishft (iachar (bytes(i + 2), kind = rik), 16)
   n3 = ishft (iachar (bytes(i + 3), kind = rik), 24)
   n = ior (n0, ior (n1, ior (n2, n3)))
 end subroutine uint32_from_vm_bytes

end module helper_procedures

module string_buffers 

 use, intrinsic :: iso_fortran_env, only: error_unit
 use, intrinsic :: iso_fortran_env, only: int64
 use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
 use, non_intrinsic :: helper_procedures

 implicit none
 private

 public :: strbuf_t
 public :: skip_whitespace
 public :: skip_non_whitespace
 public :: skip_whitespace_backwards
 public :: at_end_of_line

 type :: strbuf_t
    integer(kind = nk), private :: len = 0
    !
    ! ‘chars’ is made public for efficient access to the individual
    ! characters.
    !
    character(1, kind = ck), allocatable, public :: chars(:)
  contains
    procedure, pass, private :: ensure_storage => strbuf_t_ensure_storage
    procedure, pass :: to_unicode_full_string => strbuf_t_to_unicode_full_string
    procedure, pass :: to_unicode_substring => strbuf_t_to_unicode_substring
    procedure, pass :: length => strbuf_t_length
    procedure, pass :: set => strbuf_t_set
    procedure, pass :: append => strbuf_t_append
    generic :: to_unicode => to_unicode_full_string
    generic :: to_unicode => to_unicode_substring
    generic :: assignment(=) => set
 end type strbuf_t

contains 

 function strbuf_t_to_unicode_full_string (strbuf) result (s)
   class(strbuf_t), intent(in) :: strbuf
   character(:, kind = ck), allocatable :: s

   !
   ! This does not actually ensure that the string is valid Unicode;
   ! any 31-bit ‘character’ is supported.
   !

   integer(kind = nk) :: i

   allocate (character(len = strbuf%len, kind = ck) :: s)
   do i = 1, strbuf%len
      s(i:i) = strbuf%chars(i)
   end do
 end function strbuf_t_to_unicode_full_string

 function strbuf_t_to_unicode_substring (strbuf, i, j) result (s)
   !
   ! ‘Extreme’ values of i and j are allowed, as shortcuts for ‘from
   ! the beginning’, ‘up to the end’, or ‘empty substring’.
   !
   class(strbuf_t), intent(in) :: strbuf
   integer(kind = nk), intent(in) :: i, j
   character(:, kind = ck), allocatable :: s

   !
   ! This does not actually ensure that the string is valid Unicode;
   ! any 31-bit ‘character’ is supported.
   !

   integer(kind = nk) :: i1, j1
   integer(kind = nk) :: n
   integer(kind = nk) :: k

   i1 = max (1_nk, i)
   j1 = min (strbuf%len, j)
   n = max (0_nk, (j1 - i1) + 1_nk)

   allocate (character(n, kind = ck) :: s)
   do k = 1, n
      s(k:k) = strbuf%chars(i1 + (k - 1_nk))
   end do
 end function strbuf_t_to_unicode_substring

 elemental function strbuf_t_length (strbuf) result (n)
   class(strbuf_t), intent(in) :: strbuf
   integer(kind = nk) :: n

   n = strbuf%len
 end function strbuf_t_length

 subroutine strbuf_t_ensure_storage (strbuf, length_needed)
   class(strbuf_t), intent(inout) :: strbuf
   integer(kind = nk), intent(in) :: length_needed

   integer(kind = nk) :: len_needed
   integer(kind = nk) :: new_size
   type(strbuf_t) :: new_strbuf

   len_needed = max (length_needed, 1_nk)

   if (.not. allocated (strbuf%chars)) then
      ! Initialize a new strbuf%chars array.
      new_size = new_storage_size (len_needed)
      allocate (strbuf%chars(1:new_size))
   else if (ubound (strbuf%chars, 1) < len_needed) then
      ! Allocate a new strbuf%chars array, larger than the current
      ! one, but containing the same characters.
      new_size = new_storage_size (len_needed)
      allocate (new_strbuf%chars(1:new_size))
      new_strbuf%chars(1:strbuf%len) = strbuf%chars(1:strbuf%len)
      call move_alloc (new_strbuf%chars, strbuf%chars)
   end if
 end subroutine strbuf_t_ensure_storage

 subroutine strbuf_t_set (dst, src)
   class(strbuf_t), intent(inout) :: dst
   class(*), intent(in) :: src

   integer(kind = nk) :: n
   integer(kind = nk) :: i

   select type (src)
   type is (character(*, kind = ck))
      n = len (src, kind = nk)
      call dst%ensure_storage(n)
      do i = 1, n
         dst%chars(i) = src(i:i)
      end do
      dst%len = n
   type is (character(*))
      n = len (src, kind = nk)
      call dst%ensure_storage(n)
      do i = 1, n
         dst%chars(i) = src(i:i)
      end do
      dst%len = n
   class is (strbuf_t)
      n = src%len
      call dst%ensure_storage(n)
      dst%chars(1:n) = src%chars(1:n)
      dst%len = n
   class default
      error stop
   end select
 end subroutine strbuf_t_set

 subroutine strbuf_t_append (dst, src)
   class(strbuf_t), intent(inout) :: dst
   class(*), intent(in) :: src

   integer(kind = nk) :: n_dst, n_src, n
   integer(kind = nk) :: i

   select type (src)
   type is (character(*, kind = ck))
      n_dst = dst%len
      n_src = len (src, kind = nk)
      n = n_dst + n_src
      call dst%ensure_storage(n)
      do i = 1, n_src
         dst%chars(n_dst + i) = src(i:i)
      end do
      dst%len = n
   type is (character(*))
      n_dst = dst%len
      n_src = len (src, kind = nk)
      n = n_dst + n_src
      call dst%ensure_storage(n)
      do i = 1, n_src
         dst%chars(n_dst + i) = src(i:i)
      end do
      dst%len = n
   class is (strbuf_t)
      n_dst = dst%len
      n_src = src%len
      n = n_dst + n_src
      call dst%ensure_storage(n)
      dst%chars((n_dst + 1):n) = src%chars(1:n_src)
      dst%len = n
   class default
      error stop
   end select
 end subroutine strbuf_t_append

 function skip_whitespace (strbuf, i) result (j)
   class(strbuf_t), intent(in) :: strbuf
   integer(kind = nk), intent(in) :: i
   integer(kind = nk) :: j

   logical :: done

   j = i
   done = .false.
   do while (.not. done)
      if (at_end_of_line (strbuf, j)) then
         done = .true.
      else if (.not. isspace (strbuf%chars(j))) then
         done = .true.
      else
         j = j + 1
      end if
   end do
 end function skip_whitespace

 function skip_non_whitespace (strbuf, i) result (j)
   class(strbuf_t), intent(in) :: strbuf
   integer(kind = nk), intent(in) :: i
   integer(kind = nk) :: j

   logical :: done

   j = i
   done = .false.
   do while (.not. done)
      if (at_end_of_line (strbuf, j)) then
         done = .true.
      else if (isspace (strbuf%chars(j))) then
         done = .true.
      else
         j = j + 1
      end if
   end do
 end function skip_non_whitespace

 function skip_whitespace_backwards (strbuf, i) result (j)
   class(strbuf_t), intent(in) :: strbuf
   integer(kind = nk), intent(in) :: i
   integer(kind = nk) :: j

   logical :: done

   j = i
   done = .false.
   do while (.not. done)
      if (j == -1) then
         done = .true.
      else if (.not. isspace (strbuf%chars(j))) then
         done = .true.
      else
         j = j - 1
      end if
   end do
 end function skip_whitespace_backwards

 function at_end_of_line (strbuf, i) result (bool)
   class(strbuf_t), intent(in) :: strbuf
   integer(kind = nk), intent(in) :: i
   logical :: bool

   bool = (strbuf%length() < i)
 end function at_end_of_line

end module string_buffers

module reading_one_line_from_a_stream 

 use, intrinsic :: iso_fortran_env, only: input_unit
 use, intrinsic :: iso_fortran_env, only: error_unit
 use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
 use, non_intrinsic :: string_buffers

 implicit none
 private

 ! get_line_from_stream: read an entire input line from a stream into
 ! a strbuf_t.
 public :: get_line_from_stream

 character(1, kind = ck), parameter :: linefeed_char = char (10, kind = ck)

 ! The following is correct for Unix and its relatives.
 character(1, kind = ck), parameter :: newline_char = linefeed_char

contains 

 subroutine get_line_from_stream (unit_no, eof, no_newline, strbuf)
   integer, intent(in) :: unit_no
   logical, intent(out) :: eof ! End of file?
   logical, intent(out) :: no_newline ! There is a line but it has no
                                      ! newline? (Thus eof also must
                                      ! be .true.)
   class(strbuf_t), intent(inout) :: strbuf

   character(1, kind = ck) :: ch

   strbuf = 
   call get_ch (unit_no, eof, ch)
   do while (.not. eof .and. ch /= newline_char)
      call strbuf%append (ch)
      call get_ch (unit_no, eof, ch)
   end do
   no_newline = eof .and. (strbuf%length() /= 0)
 end subroutine get_line_from_stream

 subroutine get_ch (unit_no, eof, ch)
   !
   ! Read a single code point from the stream.
   !
   ! Currently this procedure simply inputs ‘ASCII’ bytes rather than
   ! Unicode code points.
   !
   integer, intent(in) :: unit_no
   logical, intent(out) :: eof
   character(1, kind = ck), intent(out) :: ch

   integer :: stat
   character(1) :: c = '*'

   eof = .false.

   if (unit_no == input_unit) then
      call get_input_unit_char (c, stat)
   else
      read (unit = unit_no, iostat = stat) c
   end if

   if (stat < 0) then
      ch = ck_'*'
      eof = .true.
   else if (0 < stat) then
      write (error_unit, '("Input error with status code ", I0)') stat
      stop 1
   else
      ch = char (ichar (c, kind = ick), kind = ck)
   end if
 end subroutine get_ch

!!! !!! If you tell gfortran you want -std=f2008 or -std=f2018, you likely !!! will need to add also -fall-intrinsics or -U__GFORTRAN__ !!! !!! The first way, you get the FGETC intrinsic. The latter way, you !!! get the C interface code that uses getchar(3). !!!

  1. ifdef __GFORTRAN__
 subroutine get_input_unit_char (c, stat)
   !
   ! The following works if you are using gfortran.
   !
   ! (FGETC is considered a feature for backwards compatibility with
   ! g77. However, I know of no way to reconfigure input_unit as a
   ! Fortran 2003 stream, for use with ordinary ‘read’.)
   !
   character, intent(inout) :: c
   integer, intent(out) :: stat

   call fgetc (input_unit, c, stat)
 end subroutine get_input_unit_char
  1. else
 subroutine get_input_unit_char (c, stat)
   !
   ! An alternative implementation of get_input_unit_char. This
   ! actually reads input from the C standard input, which might not
   ! be the same as input_unit.
   !
   use, intrinsic :: iso_c_binding, only: c_int
   character, intent(inout) :: c
   integer, intent(out) :: stat

   interface
      !
      ! Use getchar(3) to read characters from standard input. This
      ! assumes there is actually such a function available, and that
      ! getchar(3) does not exist solely as a macro. (One could write
      ! one’s own getchar() if necessary, of course.)
      !
      function getchar () result (c) bind (c, name = 'getchar')
        use, intrinsic :: iso_c_binding, only: c_int
        integer(kind = c_int) :: c
      end function getchar
   end interface

   integer(kind = c_int) :: i_char

   i_char = getchar ()
   !
   ! The C standard requires that EOF have a negative value. If the
   ! value returned by getchar(3) is not EOF, then it will be
   ! representable as an unsigned char. Therefore, to check for end
   ! of file, one need only test whether i_char is negative.
   !
   if (i_char < 0) then
      stat = -1
   else
      stat = 0
      c = char (i_char)
   end if
 end subroutine get_input_unit_char
  1. endif

end module reading_one_line_from_a_stream

module ast_reader 

 !
 ! The AST will be read into an array. Perhaps that will improve
 ! locality, compared to storing the AST as many linked heap nodes.
 !
 ! In any case, implementing the AST this way is an interesting
 ! problem.
 !

 use, intrinsic :: iso_fortran_env, only: input_unit
 use, intrinsic :: iso_fortran_env, only: output_unit
 use, intrinsic :: iso_fortran_env, only: error_unit
 use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick, rik
 use, non_intrinsic :: helper_procedures, only: next_power_of_two
 use, non_intrinsic :: helper_procedures, only: new_storage_size
 use, non_intrinsic :: string_buffers
 use, non_intrinsic :: reading_one_line_from_a_stream

 implicit none
 private

 public :: string_table_t
 public :: ast_node_t
 public :: ast_t
 public :: read_ast

 integer, parameter, public :: node_Nil = 0
 integer, parameter, public :: node_Identifier = 1
 integer, parameter, public :: node_String = 2
 integer, parameter, public :: node_Integer = 3
 integer, parameter, public :: node_Sequence = 4
 integer, parameter, public :: node_If = 5
 integer, parameter, public :: node_Prtc = 6
 integer, parameter, public :: node_Prts = 7
 integer, parameter, public :: node_Prti = 8
 integer, parameter, public :: node_While = 9
 integer, parameter, public :: node_Assign = 10
 integer, parameter, public :: node_Negate = 11
 integer, parameter, public :: node_Not = 12
 integer, parameter, public :: node_Multiply = 13
 integer, parameter, public :: node_Divide = 14
 integer, parameter, public :: node_Mod = 15
 integer, parameter, public :: node_Add = 16
 integer, parameter, public :: node_Subtract = 17
 integer, parameter, public :: node_Less = 18
 integer, parameter, public :: node_LessEqual = 19
 integer, parameter, public :: node_Greater = 20
 integer, parameter, public :: node_GreaterEqual = 21
 integer, parameter, public :: node_Equal = 22
 integer, parameter, public :: node_NotEqual = 23
 integer, parameter, public :: node_And = 24
 integer, parameter, public :: node_Or = 25

 type :: string_table_element_t
    character(:, kind = ck), allocatable :: str
 end type string_table_element_t

 type :: string_table_t
    integer(kind = nk), private :: len = 0_nk
    type(string_table_element_t), allocatable, private :: strings(:)
  contains
    procedure, pass, private :: ensure_storage => string_table_t_ensure_storage
    procedure, pass :: look_up_index => string_table_t_look_up_index
    procedure, pass :: look_up_string => string_table_t_look_up_string
    procedure, pass :: length => string_table_t_length
    generic :: look_up => look_up_index
    generic :: look_up => look_up_string
 end type string_table_t

 type :: ast_node_t
    integer :: node_variety

    ! Runtime integer, symbol index, or string index.
    integer(kind = rik) :: int

    ! The left branch begins at the next node. The right branch
    ! begins at the address of the left branch, plus the following.
    integer(kind = nk) :: right_branch_offset
 end type ast_node_t

 type :: ast_t
    integer(kind = nk), private :: len = 0_nk
    type(ast_node_t), allocatable, public :: nodes(:)
  contains
    procedure, pass, private :: ensure_storage => ast_t_ensure_storage
 end type ast_t

contains 

 subroutine string_table_t_ensure_storage (table, length_needed)
   class(string_table_t), intent(inout) :: table
   integer(kind = nk), intent(in) :: length_needed

   integer(kind = nk) :: len_needed
   integer(kind = nk) :: new_size
   type(string_table_t) :: new_table

   len_needed = max (length_needed, 1_nk)

   if (.not. allocated (table%strings)) then
      ! Initialize a new table%strings array.
      new_size = new_storage_size (len_needed)
      allocate (table%strings(1:new_size))
   else if (ubound (table%strings, 1) < len_needed) then
      ! Allocate a new table%strings array, larger than the current
      ! one, but containing the same strings.
      new_size = new_storage_size (len_needed)
      allocate (new_table%strings(1:new_size))
      new_table%strings(1:table%len) = table%strings(1:table%len)
      call move_alloc (new_table%strings, table%strings)
   end if
 end subroutine string_table_t_ensure_storage

 elemental function string_table_t_length (table) result (len)
   class(string_table_t), intent(in) :: table
   integer(kind = nk) :: len

   len = table%len
 end function string_table_t_length

 function string_table_t_look_up_index (table, str) result (index)
   class(string_table_t), intent(inout) :: table
   character(*, kind = ck), intent(in) :: str
   integer(kind = rik) :: index

   !
   ! This implementation simply stores the strings sequentially into
   ! an array. Obviously, for large numbers of strings, one might
   ! wish to do something more complex.
   !
   ! Standard Fortran does not come, out of the box, with a massive
   ! runtime library for doing such things. They are, however, no
   ! longer nearly as challenging to implement in Fortran as they
   ! used to be.
   !

   integer(kind = nk) :: i

   i = 1
   index = 0
   do while (index == 0)
      if (i == table%len + 1) then
         ! The string is new and must be added to the table.
         i = table%len + 1
         if (huge (1_rik) < i) then
            ! String indices are assumed to be storable as runtime
            ! integers.
            write (error_unit, '("string_table_t capacity exceeded")')
            stop 1
         end if
         call table%ensure_storage(i)
         table%len = i
         allocate (table%strings(i)%str, source = str)
         index = int (i, kind = rik)
      else if (table%strings(i)%str == str) then
         index = int (i, kind = rik)
      else
         i = i + 1
      end if
   end do
 end function string_table_t_look_up_index

 function string_table_t_look_up_string (table, index) result (str)
   class(string_table_t), intent(inout) :: table
   integer(kind = rik), intent(in) :: index
   character(:, kind = ck), allocatable :: str

   !
   ! This is the reverse of string_table_t_look_up_index: given an
   ! index, find the string.
   !

   if (index < 1 .or. table%len < index) then
      ! In correct code, this branch should never be reached.
      error stop
   else
      allocate (str, source = table%strings(index)%str)
   end if
 end function string_table_t_look_up_string

 subroutine ast_t_ensure_storage (ast, length_needed)
   class(ast_t), intent(inout) :: ast
   integer(kind = nk), intent(in) :: length_needed

   integer(kind = nk) :: len_needed
   integer(kind = nk) :: new_size
   type(ast_t) :: new_ast

   len_needed = max (length_needed, 1_nk)

   if (.not. allocated (ast%nodes)) then
      ! Initialize a new ast%nodes array.
      new_size = new_storage_size (len_needed)
      allocate (ast%nodes(1:new_size))
   else if (ubound (ast%nodes, 1) < len_needed) then
      ! Allocate a new ast%nodes array, larger than the current one,
      ! but containing the same nodes.
      new_size = new_storage_size (len_needed)
      allocate (new_ast%nodes(1:new_size))
      new_ast%nodes(1:ast%len) = ast%nodes(1:ast%len)
      call move_alloc (new_ast%nodes, ast%nodes)
   end if
 end subroutine ast_t_ensure_storage

 subroutine read_ast (unit_no, strbuf, ast, symtab, strtab)
   integer, intent(in) :: unit_no
   type(strbuf_t), intent(inout) :: strbuf
   type(ast_t), intent(inout) :: ast
   type(string_table_t), intent(inout) :: symtab
   type(string_table_t), intent(inout) :: strtab

   logical :: eof
   logical :: no_newline
   integer(kind = nk) :: after_ast_address
   
   ast%len = 0
   symtab%len = 0
   strtab%len = 0
   call build_subtree (1_nk, after_ast_address)

 contains

   recursive subroutine build_subtree (here_address, after_subtree_address)
     integer(kind = nk), value :: here_address
     integer(kind = nk), intent(out) :: after_subtree_address

     integer :: node_variety
     integer(kind = nk) :: i, j
     integer(kind = nk) :: left_branch_address
     integer(kind = nk) :: right_branch_address

     ! Get a line from the parser output.
     call get_line_from_stream (unit_no, eof, no_newline, strbuf)

     if (eof) then
        call ast_error
     else
        ! Prepare to store a new node.
        call ast%ensure_storage(here_address)
        ast%len = here_address

        ! What sort of node is it?
        i = skip_whitespace (strbuf, 1_nk)
        j = skip_non_whitespace (strbuf, i)
        node_variety = strbuf_to_node_variety (strbuf, i, j - 1)

        ast%nodes(here_address)%node_variety = node_variety

        select case (node_variety)
        case (node_Nil)
           after_subtree_address = here_address + 1
        case (node_Identifier)
           i = skip_whitespace (strbuf, j)
           j = skip_non_whitespace (strbuf, i)
           ast%nodes(here_address)%int = &
                &   strbuf_to_symbol_index (strbuf, i, j - 1, symtab)
           after_subtree_address = here_address + 1
        case (node_String)
           i = skip_whitespace (strbuf, j)
           j = skip_whitespace_backwards (strbuf, strbuf%length())
           ast%nodes(here_address)%int = &
                &   strbuf_to_string_index (strbuf, i, j, strtab)
           after_subtree_address = here_address + 1
        case (node_Integer)
           i = skip_whitespace (strbuf, j)
           j = skip_non_whitespace (strbuf, i)
           ast%nodes(here_address)%int = strbuf_to_int (strbuf, i, j - 1)
           after_subtree_address = here_address + 1
        case default
           ! The node is internal, and has left and right branches.
           ! The left branch will start at left_branch_address; the
           ! right branch will start at left_branch_address +
           ! right_side_offset.
           left_branch_address = here_address + 1
           ! Build the left branch.
           call build_subtree (left_branch_address, right_branch_address)
           ! Build the right_branch.
           call build_subtree (right_branch_address, after_subtree_address)
           ast%nodes(here_address)%right_branch_offset = &
                &   right_branch_address - left_branch_address
        end select

     end if
   end subroutine build_subtree
   
 end subroutine read_ast

 function strbuf_to_node_variety (strbuf, i, j) result (node_variety)
   class(strbuf_t), intent(in) :: strbuf
   integer(kind = nk), intent(in) :: i, j
   integer :: node_variety

   !
   ! This function has not been optimized in any way, unless the
   ! Fortran compiler can optimize it.
   !
   ! Something like a ‘radix tree search’ could be done on the
   ! characters of the strbuf. Or a perfect hash function. Or a
   ! binary search. Etc.
   !

   if (j == i - 1) then
      call ast_error
   else
      select case (strbuf%to_unicode(i, j))
      case (ck_";")
         node_variety = node_Nil
      case (ck_"Identifier")
         node_variety = node_Identifier
      case (ck_"String")
         node_variety = node_String
      case (ck_"Integer")
         node_variety = node_Integer
      case (ck_"Sequence")
         node_variety = node_Sequence
      case (ck_"If")
         node_variety = node_If
      case (ck_"Prtc")
         node_variety = node_Prtc
      case (ck_"Prts")
         node_variety = node_Prts
      case (ck_"Prti")
         node_variety = node_Prti
      case (ck_"While")
         node_variety = node_While
      case (ck_"Assign")
         node_variety = node_Assign
      case (ck_"Negate")
         node_variety = node_Negate
      case (ck_"Not")
         node_variety = node_Not
      case (ck_"Multiply")
         node_variety = node_Multiply
      case (ck_"Divide")
         node_variety = node_Divide
      case (ck_"Mod")
         node_variety = node_Mod
      case (ck_"Add")
         node_variety = node_Add
      case (ck_"Subtract")
         node_variety = node_Subtract
      case (ck_"Less")
         node_variety = node_Less
      case (ck_"LessEqual")
         node_variety = node_LessEqual
      case (ck_"Greater")
         node_variety = node_Greater
      case (ck_"GreaterEqual")
         node_variety = node_GreaterEqual
      case (ck_"Equal")
         node_variety = node_Equal
      case (ck_"NotEqual")
         node_variety = node_NotEqual
      case (ck_"And")
         node_variety = node_And
      case (ck_"Or")
         node_variety = node_Or
      case default
         call ast_error
      end select
   end if
 end function strbuf_to_node_variety

 function strbuf_to_symbol_index (strbuf, i, j, symtab) result (int)
   class(strbuf_t), intent(in) :: strbuf
   integer(kind = nk), intent(in) :: i, j
   type(string_table_t), intent(inout) :: symtab
   integer(kind = rik) :: int

   if (j == i - 1) then
      call ast_error
   else
      int = symtab%look_up(strbuf%to_unicode (i, j))
   end if
 end function strbuf_to_symbol_index

 function strbuf_to_int (strbuf, i, j) result (int)
   class(strbuf_t), intent(in) :: strbuf
   integer(kind = nk), intent(in) :: i, j
   integer(kind = rik) :: int

   integer :: stat
   character(:, kind = ck), allocatable :: str

   if (j < i) then
      call ast_error
   else
      allocate (character(len = (j - i) + 1_nk, kind = ck) :: str)
      str = strbuf%to_unicode (i, j)
      read (str, *, iostat = stat) int
      if (stat /= 0) then
         call ast_error
      end if
   end if
 end function strbuf_to_int

 function strbuf_to_string_index (strbuf, i, j, strtab) result (int)
   class(strbuf_t), intent(in) :: strbuf
   integer(kind = nk), intent(in) :: i, j
   type(string_table_t), intent(inout) :: strtab
   integer(kind = rik) :: int

   if (j == i - 1) then
      call ast_error
   else
      int = strtab%look_up(strbuf_to_string (strbuf, i, j))
   end if
 end function strbuf_to_string_index

 function strbuf_to_string (strbuf, i, j) result (str)
   class(strbuf_t), intent(in) :: strbuf
   integer(kind = nk), intent(in) :: i, j
   character(:, kind = ck), allocatable :: str

   character(1, kind = ck), parameter :: linefeed_char = char (10, kind = ck)
   character(1, kind = ck), parameter :: backslash_char = char (92, kind = ck)

   ! The following is correct for Unix and its relatives.
   character(1, kind = ck), parameter :: newline_char = linefeed_char

   integer(kind = nk) :: k
   integer(kind = nk) :: count

   if (strbuf%chars(i) /= ck_'"' .or. strbuf%chars(j) /= ck_'"') then
      call ast_error
   else
      ! Count how many characters are needed.
      count = 0
      k = i + 1
      do while (k < j)
         count = count + 1
         if (strbuf%chars(k) == backslash_char) then
            k = k + 2
         else
            k = k + 1
         end if
      end do

      allocate (character(len = count, kind = ck) :: str)

      count = 0
      k = i + 1
      do while (k < j)
         if (strbuf%chars(k) == backslash_char) then
            if (k == j - 1) then
               call ast_error
            else
               select case (strbuf%chars(k + 1))
               case (ck_'n')
                  count = count + 1
                  str(count:count) = newline_char
               case (backslash_char)
                  count = count + 1
                  str(count:count) = backslash_char
               case default
                  call ast_error
               end select
               k = k + 2
            end if
         else
            count = count + 1
            str(count:count) = strbuf%chars(k)
            k = k + 1
         end if
      end do
   end if
 end function strbuf_to_string

 subroutine ast_error
   !
   ! It might be desirable to give more detail.
   !
   write (error_unit, '("The AST input seems corrupted.")')
   stop 1
 end subroutine ast_error

end module ast_reader

module code_generation 

 !
 ! First we generate code as if the virtual machine itself were part
 ! of this program. Then we disassemble the generated code.
 !
 ! Because we are targeting only the one output language, this seems
 ! an easy way to perform the task.
 !
 !
 ! A point worth noting: the virtual machine is a stack
 ! architecture.
 !
 ! Stack architectures have a long history. Burroughs famously
 ! preferred stack architectures for running Algol programs. See, for
 ! instance,
 ! https://en.wikipedia.org/w/index.php?title=Burroughs_large_systems&oldid=1068076420
 !

 use, intrinsic :: iso_fortran_env, only: input_unit
 use, intrinsic :: iso_fortran_env, only: output_unit
 use, intrinsic :: iso_fortran_env, only: error_unit
 use, non_intrinsic :: compiler_type_kinds
 use, non_intrinsic :: helper_procedures
 use, non_intrinsic :: ast_reader

 implicit none
 private

 public :: generate_and_output_code
 public :: generate_code
 public :: output_code

 ! The virtual machine cannot handle integers of more than 32 bits,
 ! two’s-complement.
 integer(kind = rik), parameter :: vm_huge_negint = -(2_rik ** 31_rik)
 integer(kind = rik), parameter :: vm_huge_posint = (2_rik ** 31_rik) - 1_rik

 ! Arbitrarily chosen opcodes.
 integer, parameter :: opcode_nop = 0 ! I think there should be a nop
                                      ! opcode, to reserve space for
                                      ! later hand-patching. :)
 integer, parameter :: opcode_halt = 1 ! Does the ‘halt’ instruction
                                       ! apply brakes to the drum?
 integer, parameter :: opcode_add = 2
 integer, parameter :: opcode_sub = 3
 integer, parameter :: opcode_mul = 4
 integer, parameter :: opcode_div = 5
 integer, parameter :: opcode_mod = 6
 integer, parameter :: opcode_lt = 7
 integer, parameter :: opcode_gt = 8
 integer, parameter :: opcode_le = 9
 integer, parameter :: opcode_ge = 10
 integer, parameter :: opcode_eq = 11
 integer, parameter :: opcode_ne = 12
 integer, parameter :: opcode_and = 13
 integer, parameter :: opcode_or = 14
 integer, parameter :: opcode_neg = 15
 integer, parameter :: opcode_not = 16
 integer, parameter :: opcode_prtc = 17
 integer, parameter :: opcode_prti = 18
 integer, parameter :: opcode_prts = 19
 integer, parameter :: opcode_fetch = 20
 integer, parameter :: opcode_store = 21
 integer, parameter :: opcode_push = 22
 integer, parameter :: opcode_jmp = 23
 integer, parameter :: opcode_jz = 24

 character(8, kind = ck), parameter :: opcode_names(0:24) = &
      & (/ "nop     ",   &
      &    "halt    ",   &
      &    "add     ",   &
      &    "sub     ",   &
      &    "mul     ",   &
      &    "div     ",   &
      &    "mod     ",   &
      &    "lt      ",   &
      &    "gt      ",   &
      &    "le      ",   &
      &    "ge      ",   &
      &    "eq      ",   &
      &    "ne      ",   &
      &    "and     ",   &
      &    "or      ",   &
      &    "neg     ",   &
      &    "not     ",   &
      &    "prtc    ",   &
      &    "prti    ",   &
      &    "prts    ",   &
      &    "fetch   ",   &
      &    "store   ",   &
      &    "push    ",   &
      &    "jmp     ",   &
      &    "jz      " /)

 type :: vm_code_t
    integer(kind = rik), private :: len = 0_rik
    character(1), allocatable :: bytes(:)
  contains
    procedure, pass, private :: ensure_storage => vm_code_t_ensure_storage
    procedure, pass :: length => vm_code_t_length
 end type vm_code_t

contains 

 subroutine vm_code_t_ensure_storage (code, length_needed)
   class(vm_code_t), intent(inout) :: code
   integer(kind = nk), intent(in) :: length_needed

   integer(kind = nk) :: len_needed
   integer(kind = nk) :: new_size
   type(vm_code_t) :: new_code

   len_needed = max (length_needed, 1_nk)

   if (.not. allocated (code%bytes)) then
      ! Initialize a new code%bytes array.
      new_size = new_storage_size (len_needed)
      allocate (code%bytes(0:(new_size - 1)))
   else if (ubound (code%bytes, 1) < len_needed - 1) then
      ! Allocate a new code%bytes array, larger than the current one,
      ! but containing the same bytes.
      new_size = new_storage_size (len_needed)
      allocate (new_code%bytes(0:(new_size - 1)))
      new_code%bytes(0:(code%len - 1)) = code%bytes(0:(code%len - 1))
      call move_alloc (new_code%bytes, code%bytes)
   end if
 end subroutine vm_code_t_ensure_storage

 elemental function vm_code_t_length (code) result (len)
   class(vm_code_t), intent(in) :: code
   integer(kind = rik) :: len

   len = code%len
 end function vm_code_t_length

 subroutine generate_and_output_code (outp, ast, symtab, strtab)
   integer, intent(in) :: outp ! The unit to write the output to.
   type(ast_t), intent(in) :: ast
   type(string_table_t), intent(inout) :: symtab
   type(string_table_t), intent(inout) :: strtab

   type(vm_code_t) :: code
   integer(kind = rik) :: i_vm

   code%len = 0
   i_vm = 0_rik
   call generate_code (ast, 1_nk, i_vm, code)
   call output_code (outp, symtab, strtab, code)
 end subroutine generate_and_output_code

 subroutine generate_code (ast, i_ast, i_vm, code)
   type(ast_t), intent(in) :: ast
   integer(kind = nk), intent(in) :: i_ast ! Index in the ast array.
   integer(kind = rik), intent(inout) :: i_vm ! Address in the virtual machine.
   type(vm_code_t), intent(inout) :: code

   call traverse (i_ast)

   ! Generate a halt instruction.
   call code%ensure_storage(i_vm + 1)
   code%bytes(i_vm) = achar (opcode_halt)
   i_vm = i_vm + 1

   code%len = i_vm

 contains

   recursive subroutine traverse (i_ast)
     integer(kind = nk), intent(in) :: i_ast ! Index in the ast array.

     select case (ast%nodes(i_ast)%node_variety)

     case (node_Nil)
        continue

     case (node_Integer)
        block
          integer(kind = rik) :: int_value

          int_value = ast%nodes(i_ast)%int
          call ensure_integer_is_vm_compatible (int_value)
          call code%ensure_storage(i_vm + 5)
          code%bytes(i_vm) = achar (opcode_push)
          call int32_to_vm_bytes (int_value, code%bytes, i_vm + 1)
          i_vm = i_vm + 5
        end block

     case (node_Identifier)
        block
          integer(kind = rik) :: variable_index

          ! In the best Fortran tradition, we indexed the variables
          ! starting at one; however, the virtual machine starts them
          ! at zero. So subtract 1.
          variable_index = ast%nodes(i_ast)%int - 1

          call ensure_integer_is_vm_compatible (variable_index)
          call code%ensure_storage(i_vm + 5)
          code%bytes(i_vm) = achar (opcode_fetch)
          call uint32_to_vm_bytes (variable_index, code%bytes, i_vm + 1)
          i_vm = i_vm + 5
        end block

     case (node_String)
        block
          integer(kind = rik) :: string_index

          ! In the best Fortran tradition, we indexed the strings
          ! starting at one; however, the virtual machine starts them
          ! at zero. So subtract 1.
          string_index = ast%nodes(i_ast)%int - 1

          call ensure_integer_is_vm_compatible (string_index)
          call code%ensure_storage(i_vm + 5)
          code%bytes(i_vm) = achar (opcode_push)
          call uint32_to_vm_bytes (string_index, code%bytes, i_vm + 1)
          i_vm = i_vm + 5
        end block

     case (node_Assign)
        block
          integer(kind = nk) :: i_left, i_right
          integer(kind = rik) :: variable_index

          i_left = left_branch (i_ast)
          i_right = right_branch (i_ast)

          ! In the best Fortran tradition, we indexed the variables
          ! starting at one; however, the virtual machine starts them
          ! at zero. So subtract 1.
          variable_index = ast%nodes(i_left)%int - 1

          ! Create code to push the right side onto the stack
          call traverse (i_right)

          ! Create code to store that result into the variable on the
          ! left side.
          call ensure_node_variety (node_Identifier, ast%nodes(i_left)%node_variety)
          call ensure_integer_is_vm_compatible (variable_index)
          call code%ensure_storage(i_vm + 5)
          code%bytes(i_vm) = achar (opcode_store)
          call uint32_to_vm_bytes (variable_index, code%bytes, i_vm + 1)
          i_vm = i_vm + 5
        end block

     case (node_Multiply)
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_mul)
        i_vm = i_vm + 1

     case (node_Divide)
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_div)
        i_vm = i_vm + 1

     case (node_Mod)
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_mod)
        i_vm = i_vm + 1

     case (node_Add)
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_add)
        i_vm = i_vm + 1

     case (node_Subtract)
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_sub)
        i_vm = i_vm + 1

     case (node_Less)
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_lt)
        i_vm = i_vm + 1

     case (node_LessEqual)
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_le)
        i_vm = i_vm + 1

     case (node_Greater)
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_gt)
        i_vm = i_vm + 1

     case (node_GreaterEqual)
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_ge)
        i_vm = i_vm + 1

     case (node_Equal)
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_eq)
        i_vm = i_vm + 1

     case (node_NotEqual)
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_ne)
        i_vm = i_vm + 1

     case (node_Negate)
        call ensure_node_variety (node_Nil, &
             &  ast%nodes(right_branch (i_ast))%node_variety)
        call traverse (left_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_neg)
        i_vm = i_vm + 1

     case (node_Not)
        call ensure_node_variety (node_Nil, &
             &  ast%nodes(right_branch (i_ast))%node_variety)
        call traverse (left_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_not)
        i_vm = i_vm + 1

     case (node_And)
        !
        ! This is not a short-circuiting AND and so differs from
        ! C. One would not notice the difference, except in side
        ! effects that (I believe) are not possible in our tiny
        ! language.
        !
        ! Even in a language such as Fortran that has actual AND and
        ! OR operators, an optimizer may generate short-circuiting
        ! code and so spoil one’s expectations for side
        ! effects. (Therefore gfortran may issue a warning if you
        ! call an unpure function within an .AND. or
        ! .OR. expression.)
        !
        ! A C equivalent to what we have our code generator doing
        ! (and to Fortran’s .AND. operator) might be something like
        !
        !    #define AND(a, b) ((!!(a)) * (!!(b)))
        !
        ! This macro takes advantage of the equivalence of AND to
        ! multiplication modulo 2. The ‘!!’ notations are a C idiom
        ! for converting values to 0 and 1.
        !
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_and)
        i_vm = i_vm + 1

     case (node_Or)
        !
        ! This is not a short-circuiting OR and so differs from
        ! C. One would not notice the difference, except in side
        ! effects that (I believe) are not possible in our tiny
        ! language.
        !
        ! Even in a language such as Fortran that has actual AND and
        ! OR operators, an optimizer may generate short-circuiting
        ! code and so spoil one’s expectations for side
        ! effects. (Therefore gfortran may issue a warning if you
        ! call an unpure function within an .AND. or
        ! .OR. expression.)
        !
        ! A C equivalent to what we have our code generator doing
        ! (and to Fortran’s .OR. operator) might be something like
        !
        !    #define OR(a, b) (!( (!(a)) * (!(b)) ))
        !
        ! This macro takes advantage of the equivalence of AND to
        ! multiplication modulo 2, and the equivalence of OR(a,b) to
        ! !AND(!a,!b). One could instead take advantage of the
        ! equivalence of OR to addition modulo 2:
        !
        !    #define OR(a, b) ( ( (!!(a)) + (!!(b)) ) & 1 )
        !
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_or)
        i_vm = i_vm + 1

     case (node_If)
        block
          integer(kind = nk) :: i_left, i_right
          integer(kind = nk) :: i_right_then_left, i_right_then_right
          logical :: there_is_an_else_clause
          integer(kind = rik) :: fixup_address1
          integer(kind = rik) :: fixup_address2
          integer(kind = rik) :: relative_address

          i_left = left_branch (i_ast)
          i_right = right_branch (i_ast)

          call ensure_node_variety (node_If, ast%nodes(i_right)%node_variety)

          i_right_then_left = left_branch (i_right)
          i_right_then_right = right_branch (i_right)

          there_is_an_else_clause = &
               & (ast%nodes(i_right_then_right)%node_variety /= node_Nil)

          ! Generate code for the predicate.
          call traverse (i_left)

          ! Generate a conditional jump over the predicate-true code.
          call code%ensure_storage(i_vm + 5)
          code%bytes(i_vm) = achar (opcode_jz)
          call int32_to_vm_bytes (0_rik, code%bytes, i_vm + 1)
          fixup_address1 = i_vm + 1
          i_vm = i_vm + 5

          ! Generate the predicate-true code.
          call traverse (i_right_then_left)

          if (there_is_an_else_clause) then
             ! Generate an unconditional jump over the predicate-true
             ! code.
             call code%ensure_storage(i_vm + 5)
             code%bytes(i_vm) = achar (opcode_jmp)
             call int32_to_vm_bytes (0_rik, code%bytes, i_vm + 1)
             fixup_address2 = i_vm + 1
             i_vm = i_vm + 5

             ! Fix up the conditional jump, so it jumps to the
             ! predicate-false code.
             relative_address = i_vm - fixup_address1
             call int32_to_vm_bytes (relative_address, code%bytes, fixup_address1)

             ! Generate the predicate-false code.
             call traverse (i_right_then_right)

             ! Fix up the unconditional jump, so it jumps past the
             ! predicate-false code.
             relative_address = i_vm - fixup_address2
             call int32_to_vm_bytes (relative_address, code%bytes, fixup_address2)
          else
             ! Fix up the conditional jump, so it jumps past the
             ! predicate-true code.
             relative_address = i_vm - fixup_address1
             call int32_to_vm_bytes (relative_address, code%bytes, fixup_address1)
          end if
        end block

     case (node_While)
        block

          !
          ! Note there is another common way to translate a
          ! while-loop which is to put (logically inverted) predicate
          ! code *after* the loop-body code, followed by a
          ! conditional jump to the start of the loop. You start the
          ! loop by unconditionally jumping to the predicate code.
          !
          ! If our VM had a ‘jnz’ instruction, that translation would
          ! almost certainly be slightly better than this one. Given
          ! that we do not have a ‘jnz’, the code would end up
          ! slightly enlarged; one would have to put ‘not’ before the
          ! ‘jz’ at the bottom of the loop.
          !

          integer(kind = nk) :: i_left, i_right
          integer(kind = rik) :: loop_address
          integer(kind = rik) :: fixup_address
          integer(kind = rik) :: relative_address

          i_left = left_branch (i_ast)
          i_right = right_branch (i_ast)

          ! Generate code for the predicate.
          loop_address = i_vm
          call traverse (i_left)

          ! Generate a conditional jump out of the loop.
          call code%ensure_storage(i_vm + 5)
          code%bytes(i_vm) = achar (opcode_jz)
          call int32_to_vm_bytes (0_rik, code%bytes, i_vm + 1)
          fixup_address = i_vm + 1
          i_vm = i_vm + 5

          ! Generate code for the loop body.
          call traverse (i_right)

          ! Generate an unconditional jump to the top of the loop.
          call code%ensure_storage(i_vm + 5)
          code%bytes(i_vm) = achar (opcode_jmp)
          relative_address = loop_address - (i_vm + 1)
          call int32_to_vm_bytes (relative_address, code%bytes, i_vm + 1)
          i_vm = i_vm + 5

          ! Fix up the conditional jump, so it jumps after the loop
          ! body.
          relative_address = i_vm - fixup_address
          call int32_to_vm_bytes (relative_address, code%bytes, fixup_address)
        end block

     case (node_Prtc)
        call ensure_node_variety (node_Nil, &
             &  ast%nodes(right_branch (i_ast))%node_variety)
        call traverse (left_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_prtc)
        i_vm = i_vm + 1

     case (node_Prti)
        call ensure_node_variety (node_Nil, &
             &  ast%nodes(right_branch (i_ast))%node_variety)
        call traverse (left_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_prti)
        i_vm = i_vm + 1

     case (node_Prts)
        call ensure_node_variety (node_Nil, &
             &  ast%nodes(right_branch (i_ast))%node_variety)
        call traverse (left_branch (i_ast))
        call code%ensure_storage(i_vm + 1)
        code%bytes(i_vm) = achar (opcode_prts)
        i_vm = i_vm + 1

     case (node_Sequence)
        call traverse (left_branch (i_ast))
        call traverse (right_branch (i_ast))

     case default
        call bad_ast

     end select

     code%len = i_vm

   end subroutine traverse

   elemental function left_branch (i_here) result (i_left)
     integer(kind = nk), intent(in) :: i_here
     integer(kind = nk) :: i_left

     i_left = i_here + 1
   end function left_branch

   elemental function right_branch (i_here) result (i_right)
     integer(kind = nk), intent(in) :: i_here
     integer(kind = nk) :: i_right

     i_right = i_here + 1 + ast%nodes(i_here)%right_branch_offset
   end function right_branch

   subroutine ensure_node_variety (expected_node_variety, found_node_variety)
     integer, intent(in) :: expected_node_variety
     integer, intent(in) :: found_node_variety
     if (expected_node_variety /= found_node_variety) call bad_ast
   end subroutine ensure_node_variety

   subroutine bad_ast
     call codegen_error_message
     write (error_unit, '("unexpected abstract syntax")')
     stop 1
   end subroutine bad_ast

 end subroutine generate_code

 subroutine output_code (outp, symtab, strtab, code)
   integer, intent(in) :: outp ! The unit to write the output to.
   type(string_table_t), intent(inout) :: symtab
   type(string_table_t), intent(inout) :: strtab
   type(vm_code_t), intent(in) :: code

   call write_header (outp, symtab%length(), strtab%length())
   call write_strings (outp, strtab)
   call disassemble_instructions (outp, code)
 end subroutine output_code

 subroutine write_header (outp, data_size, strings_size)
   integer, intent(in) :: outp
   integer(kind = rik) :: data_size
   integer(kind = rik) :: strings_size

   call ensure_integer_is_vm_compatible (data_size)
   call ensure_integer_is_vm_compatible (strings_size)
   write (outp, '("Datasize: ", I0, " Strings: ", I0)') data_size, strings_size
 end subroutine write_header

 subroutine write_strings (outp, strtab)
   integer, intent(in) :: outp
   type(string_table_t), intent(inout) :: strtab

   integer(kind = rik) :: i

   do i = 1_rik, strtab%length()
      write (outp, '(1A)') quoted_string (strtab%look_up(i))
   end do
 end subroutine write_strings

 subroutine disassemble_instructions (outp, code)
   integer, intent(in) :: outp
   type(vm_code_t), intent(in) :: code

   integer(kind = rik) :: i_vm
   integer :: opcode
   integer(kind = rik) :: n

   i_vm = 0_rik
   do while (i_vm /= code%length())
      call write_vm_code_address (outp, i_vm)
      opcode = iachar (code%bytes(i_vm))
      call write_vm_opcode (outp, opcode)
      select case (opcode)
      case (opcode_push)
         call int32_from_vm_bytes (n, code%bytes, i_vm + 1)
         call write_vm_int_literal (outp, n)
         i_vm = i_vm + 5
      case (opcode_fetch, opcode_store)
         call uint32_from_vm_bytes (n, code%bytes, i_vm + 1)
         call write_vm_data_address (outp, n)
         i_vm = i_vm + 5
      case (opcode_jmp, opcode_jz)
         call int32_from_vm_bytes (n, code%bytes, i_vm + 1)
         call write_vm_jump_address (outp, n, i_vm + 1)
         i_vm = i_vm + 5
      case default
         i_vm = i_vm + 1
      end select
      write (outp, '()', advance = 'yes')
   end do
 end subroutine disassemble_instructions

 subroutine write_vm_code_address (outp, i_vm)
   integer, intent(in) :: outp
   integer(kind = rik), intent(in) :: i_vm

   ! 10 characters is wide enough for any 32-bit unsigned number.
   write (outp, '(I10, 1X)', advance = 'no') i_vm
 end subroutine write_vm_code_address

 subroutine write_vm_opcode (outp, opcode)
   integer, intent(in) :: outp
   integer, intent(in) :: opcode

   character(8, kind = ck) :: opcode_name

   opcode_name = opcode_names(opcode)

   select case (opcode)
   case (opcode_push, opcode_fetch, opcode_store, opcode_jz, opcode_jmp)
      write (outp, '(1A)', advance = 'no') opcode_name(1:6)
   case default
      write (outp, '(1A)', advance = 'no') trim (opcode_name)
   end select
 end subroutine write_vm_opcode

 subroutine write_vm_int_literal (outp, n)
   integer, intent(in) :: outp
   integer(kind = rik), intent(in) :: n

   write (outp, '(I0)', advance = 'no') n
 end subroutine write_vm_int_literal

 subroutine write_vm_data_address (outp, i)
   integer, intent(in) :: outp
   integer(kind = rik), intent(in) :: i

   write (outp, '("[", I0, "]")', advance = 'no') i
 end subroutine write_vm_data_address

 subroutine write_vm_jump_address (outp, relative_address, i_vm)
   integer, intent(in) :: outp
   integer(kind = rik), intent(in) :: relative_address
   integer(kind = rik), intent(in) :: i_vm

   write (outp, '(" (", I0, ") ", I0)', advance = 'no') &
        &    relative_address, i_vm + relative_address
 end subroutine write_vm_jump_address

 subroutine ensure_integer_is_vm_compatible (n)
   integer(kind = rik), intent(in) :: n
   !
   ! It would seem desirable to check this in the syntax analyzer,
   ! instead, so line and column numbers can be given. But checking
   ! here will not hurt.
   !
   if (n < vm_huge_negint .or. vm_huge_posint < n) then
      call codegen_error_message
      write (error_unit, '("integer is too large for the virtual machine: ", I0)') n
      stop 1
   end if
 end subroutine ensure_integer_is_vm_compatible

 subroutine codegen_error_message
   write (error_unit, '("Code generation error: ")', advance = 'no')
 end subroutine codegen_error_message

end module code_generation

program gen 

 use, intrinsic :: iso_fortran_env, only: input_unit
 use, intrinsic :: iso_fortran_env, only: output_unit
 use, intrinsic :: iso_fortran_env, only: error_unit
 use, non_intrinsic :: compiler_type_kinds
 use, non_intrinsic :: string_buffers
 use, non_intrinsic :: ast_reader
 use, non_intrinsic :: code_generation

 implicit none

 integer, parameter :: inp_unit_no = 100
 integer, parameter :: outp_unit_no = 101

 integer :: arg_count
 character(200) :: arg
 integer :: inp
 integer :: outp

 type(strbuf_t) :: strbuf
 type(ast_t) :: ast
 type(string_table_t) :: symtab
 type(string_table_t) :: strtab

 arg_count = command_argument_count ()
 if (3 <= arg_count) then
    call print_usage
 else
    if (arg_count == 0) then
       inp = input_unit
       outp = output_unit
    else if (arg_count == 1) then
       call get_command_argument (1, arg)
       inp = open_for_input (trim (arg))
       outp = output_unit
    else if (arg_count == 2) then
       call get_command_argument (1, arg)
       inp = open_for_input (trim (arg))
       call get_command_argument (2, arg)
       outp = open_for_output (trim (arg))
    end if

    call read_ast (inp, strbuf, ast, symtab, strtab)
    call generate_and_output_code (outp, ast, symtab, strtab)
 end if

contains 

 function open_for_input (filename) result (unit_no)
   character(*), intent(in) :: filename
   integer :: unit_no

   integer :: stat

   open (unit = inp_unit_no, file = filename, status = 'old', &
        & action = 'read', access = 'stream', form = 'unformatted',  &
        & iostat = stat)
   if (stat /= 0) then
      write (error_unit, '("Error: failed to open ", 1A, " for input")') filename
      stop 1
   end if
   unit_no = inp_unit_no
 end function open_for_input

 function open_for_output (filename) result (unit_no)
   character(*), intent(in) :: filename
   integer :: unit_no

   integer :: stat

   open (unit = outp_unit_no, file = filename, action = 'write', iostat = stat)
   if (stat /= 0) then
      write (error_unit, '("Error: failed to open ", 1A, " for output")') filename
      stop 1
   end if
   unit_no = outp_unit_no
 end function open_for_output

 subroutine print_usage
   character(200) :: progname

   call get_command_argument (0, progname)
   write (output_unit, '("Usage: ", 1A, " [INPUT_FILE [OUTPUT_FILE]]")') &
        &      trim (progname)
 end subroutine print_usage

end program gen</lang>

Output:

$ ./lex compiler-tests/count.t | ./parse | ./gen 

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

Go

Translation of: C

<lang go>package main

import ( 

   "bufio"
   "encoding/binary"
   "fmt"
   "log"
   "os"
   "strconv"
   "strings"

)

type NodeType int

const ( 

   ndIdent NodeType = iota
   ndString
   ndInteger
   ndSequence
   ndIf
   ndPrtc
   ndPrts
   ndPrti
   ndWhile
   ndAssign
   ndNegate
   ndNot
   ndMul
   ndDiv
   ndMod
   ndAdd
   ndSub
   ndLss
   ndLeq
   ndGtr
   ndGeq
   ndEql
   ndNeq
   ndAnd
   ndOr

)

type code = byte

const ( 

   fetch code = iota
   store
   push
   add
   sub
   mul
   div
   mod
   lt
   gt
   le
   ge
   eq
   ne
   and
   or
   neg
   not
   jmp
   jz
   prtc
   prts
   prti
   halt

)

type Tree struct { 

   nodeType NodeType
   left     *Tree
   right    *Tree
   value    string

}

// dependency: Ordered by NodeType, must remain in same order as NodeType enum type atr struct { 

   enumText string
   nodeType NodeType
   opcode   code

}

var atrs = []atr{ 

   {"Identifier", ndIdent, 255},
   {"String", ndString, 255},
   {"Integer", ndInteger, 255},
   {"Sequence", ndSequence, 255},
   {"If", ndIf, 255},
   {"Prtc", ndPrtc, 255},
   {"Prts", ndPrts, 255},
   {"Prti", ndPrti, 255},
   {"While", ndWhile, 255},
   {"Assign", ndAssign, 255},
   {"Negate", ndNegate, neg},
   {"Not", ndNot, not},
   {"Multiply", ndMul, mul},
   {"Divide", ndDiv, div},
   {"Mod", ndMod, mod},
   {"Add", ndAdd, add},
   {"Subtract", ndSub, sub},
   {"Less", ndLss, lt},
   {"LessEqual", ndLeq, le},
   {"Greater", ndGtr, gt},
   {"GreaterEqual", ndGeq, ge},
   {"Equal", ndEql, eq},
   {"NotEqual", ndNeq, ne},
   {"And", ndAnd, and},
   {"Or", ndOr, or},

}

var ( 

   stringPool []string
   globals    []string
   object     []code

)

var ( 

   err     error
   scanner *bufio.Scanner

)

func reportError(msg string) { 

   log.Fatalf("error : %s\n", msg)

}

func check(err error) { 

   if err != nil {
       log.Fatal(err)
   }

}

func nodeType2Op(nodeType NodeType) code { 

   return atrs[nodeType].opcode

}

func makeNode(nodeType NodeType, left *Tree, right *Tree) *Tree { 

   return &Tree{nodeType, left, right, ""}

}

func makeLeaf(nodeType NodeType, value string) *Tree { 

   return &Tree{nodeType, nil, nil, value}

}

/*** Code generator ***/

func emitByte(c code) { 

   object = append(object, c)

}

func emitWord(n int) { 

   bs := make([]byte, 4)
   binary.LittleEndian.PutUint32(bs, uint32(n))
   for _, b := range bs {
       emitByte(code(b))
   }

}

func emitWordAt(at, n int) { 

   bs := make([]byte, 4)
   binary.LittleEndian.PutUint32(bs, uint32(n))
   for i := at; i < at+4; i++ {
       object[i] = code(bs[i-at])
   }

}

func hole() int { 

   t := len(object)
   emitWord(0)
   return t

}

func fetchVarOffset(id string) int { 

   for i := 0; i < len(globals); i++ {
       if globals[i] == id {
           return i
       }
   }
   globals = append(globals, id)
   return len(globals) - 1

}

func fetchStringOffset(st string) int { 

   for i := 0; i < len(stringPool); i++ {
       if stringPool[i] == st {
           return i
       }
   }
   stringPool = append(stringPool, st)
   return len(stringPool) - 1

}

func codeGen(x *Tree) { 

   if x == nil {
       return
   }
   var n, p1, p2 int
   switch x.nodeType {
   case ndIdent:
       emitByte(fetch)
       n = fetchVarOffset(x.value)
       emitWord(n)
   case ndInteger:
       emitByte(push)
       n, err = strconv.Atoi(x.value)
       check(err)
       emitWord(n)
   case ndString:
       emitByte(push)
       n = fetchStringOffset(x.value)
       emitWord(n)
   case ndAssign:
       n = fetchVarOffset(x.left.value)
       codeGen(x.right)
       emitByte(store)
       emitWord(n)
   case ndIf:
       codeGen(x.left)       // if expr
       emitByte(jz)          // if false, jump
       p1 = hole()           // make room forjump dest
       codeGen(x.right.left) // if true statements
       if x.right.right != nil {
           emitByte(jmp)
           p2 = hole()
       }
       emitWordAt(p1, len(object)-p1)
       if x.right.right != nil {
           codeGen(x.right.right)
           emitWordAt(p2, len(object)-p2)
       }
   case ndWhile:
       p1 = len(object)
       codeGen(x.left)                // while expr
       emitByte(jz)                   // if false, jump
       p2 = hole()                    // make room for jump dest
       codeGen(x.right)               // statements
       emitByte(jmp)                  // back to the top
       emitWord(p1 - len(object))     // plug the top
       emitWordAt(p2, len(object)-p2) // plug the 'if false, jump'
   case ndSequence:
       codeGen(x.left)
       codeGen(x.right)
   case ndPrtc:
       codeGen(x.left)
       emitByte(prtc)
   case ndPrti:
       codeGen(x.left)
       emitByte(prti)
   case ndPrts:
       codeGen(x.left)
       emitByte(prts)
   case ndLss, ndGtr, ndLeq, ndGeq, ndEql, ndNeq,
       ndAnd, ndOr, ndSub, ndAdd, ndDiv, ndMul, ndMod:
       codeGen(x.left)
       codeGen(x.right)
       emitByte(nodeType2Op(x.nodeType))
   case ndNegate, ndNot:
       codeGen(x.left)
       emitByte(nodeType2Op(x.nodeType))
   default:
       msg := fmt.Sprintf("error in code generator - found %d, expecting operator\n", x.nodeType)
       reportError(msg)
   }

}

func codeFinish() { 

   emitByte(halt)

}

func listCode() { 

   fmt.Printf("Datasize: %d Strings: %d\n", len(globals), len(stringPool))
   for _, s := range stringPool {
       fmt.Println(s)
   }
   pc := 0
   for pc < len(object) {
       fmt.Printf("%5d ", pc)
       op := object[pc]
       pc++
       switch op {
       case fetch:
           x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
           fmt.Printf("fetch [%d]\n", x)
           pc += 4
       case store:
           x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
           fmt.Printf("store [%d]\n", x)
           pc += 4
       case push:
           x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
           fmt.Printf("push  %d\n", x)
           pc += 4
       case add:
           fmt.Println("add")
       case sub:
           fmt.Println("sub")
       case mul:
           fmt.Println("mul")
       case div:
           fmt.Println("div")
       case mod:
           fmt.Println("mod")
       case lt:
           fmt.Println("lt")
       case gt:
           fmt.Println("gt")
       case le:
           fmt.Println("le")
       case ge:
           fmt.Println("ge")
       case eq:
           fmt.Println("eq")
       case ne:
           fmt.Println("ne")
       case and:
           fmt.Println("and")
       case or:
           fmt.Println("or")
       case neg:
           fmt.Println("neg")
       case not:
           fmt.Println("not")
       case jmp:
           x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
           fmt.Printf("jmp    (%d) %d\n", x, int32(pc)+x)
           pc += 4
       case jz:
           x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
           fmt.Printf("jz     (%d) %d\n", x, int32(pc)+x)
           pc += 4
       case prtc:
           fmt.Println("prtc")
       case prti:
           fmt.Println("prti")
       case prts:
           fmt.Println("prts")
       case halt:
           fmt.Println("halt")
       default:
           reportError(fmt.Sprintf("listCode: Unknown opcode %d", op))
       }
   }

}

func getEnumValue(name string) NodeType { 

   for _, atr := range atrs {
       if atr.enumText == name {
           return atr.nodeType
       }
   }
   reportError(fmt.Sprintf("Unknown token %s\n", name))
   return -1

}

func loadAst() *Tree { 

   var nodeType NodeType
   var s string
   if scanner.Scan() {
       line := strings.TrimRight(scanner.Text(), " \t")
       tokens := strings.Fields(line)
       first := tokens[0]
       if first[0] == ';' {
           return nil
       }
       nodeType = getEnumValue(first)
       le := len(tokens)
       if le == 2 {
           s = tokens[1]
       } else if le > 2 {
           idx := strings.Index(line, `"`)
           s = line[idx:]
       }
   }
   check(scanner.Err())
   if s != "" {
       return makeLeaf(nodeType, s)
   }
   left := loadAst()
   right := loadAst()
   return makeNode(nodeType, left, right)

}

func main() { 

   ast, err := os.Open("ast.txt")
   check(err)
   defer ast.Close()
   scanner = bufio.NewScanner(ast)
   codeGen(loadAst())
   codeFinish()
   listCode()

}</lang>

Output:

while counter example: 

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

J

Implementation: <lang J>require'format/printf'

(opcodes)=: opcodes=: ;:{{)n 

fetch store push add sub mul div mod lt gt le ge
eq ne and or neg not jmp jz prtc prts prti halt

}}-.LF

(ndDisp)=: ndDisp=:;:{{)n 

Sequence Multiply Divide Mod Add Subtract Negate Less LessEqual Greater
GreaterEqual Equal NotEqual Not And Or Prts Assign Prti x If x x x While
x x Prtc x Identifier String Integer

}}-.LF

ndDisp,.ndOps=:;: {{)n 

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

}} -.LF

load_ast=: {{ 

 'node_types node_values'=: 2{.|:(({.,&<&<}.@}.)~ i.&' ');._2 y
 1{::0 load_ast 

 node_type=. x{::node_types
 if. node_type-:,';' do. x;a: return.end.
 node_value=. x{::node_values
 if. -.-:node_value do.x;<node_type make_leaf node_value return.end.
 'x left'=.(x+1) load_ast
 'x right'=.(x+1) load_ast
 x;<node_type make_node left right

}}

make_leaf=: ; make_node=: {{m;n;<y}} typ=: 0&{:: val=: left=: 1&{:: right=: 2&{::

gen_code=: {{ 

 if.y-: do. return.end.
 V=. val y
 W=. ;2}.y
 select.op=.typ y
   case.'Integer'do.gen_int _".V [ gen_op push
   case.'String'do.gen_string V [ gen_op push
   case.'Identifier'do.gen_var V [ gen_op fetch
   case.'Assign'do.gen_var left V [ gen_op store [ gen_code W
   case.;:'Multiply Divide Mod Add Subtract Less LessEqual Greater GreaterEqual Equal NotEqual And Or'do.
     gen_op op [ gen_code W [ gen_code V
   case.;:'Not Negate'do.
     gen_op op [ gen_code V
   case.'If'do.
     p1=. gen_int 0 [ gen_op jz [ gen_code V
     gen_code left W
     if.#right W do.
       p2=. gen_int 0 [ gen_op jmp
       gen_code right W [ p1 patch #object
       p2 patch #object
     else.
       p1 patch #object
     end.
   case.'While'do.
     p1=. #object
     p2=. gen_int 0 [ gen_op jz [ gen_code V
     gen_int p1 [ gen_op jmp [ gen_code W
     p2 patch #object
   case.'Prtc'do.gen_op prtc [ gen_code V
   case.'Prti'do.gen_op prti [ gen_code V
   case.'Prts'do.gen_op prts [ gen_code V
   case.'Sequence'do.
     gen_code W [ gen_code V
   case.do.error'unknown node type ',typ y
 end.

}}

gen_op=:{{ 

  arg=. boxopen y
  if. -.arg e. opcodes do.
    arg=. (ndDisp i. arg){ndOps
  end.
  assert. arg e. opcodes
  object=: object,opcodes i.arg

}}

gen_int=:Template:If.

gen_string=: {{ 

  strings=:~.strings,<y
  gen_int strings i.<y

}}

gen_var=: {{ 

  vars=:~.vars,<y
  gen_int vars i.<y

}}

patch=: {{ #object=: ((4#256)#:y) (x+i.4)} object }} error=: Template:Echo y throw. getint=: _2147483648+4294967296|2147483648+256#.]

list_code=: Template:R=.'Datasize: %d Strings: %d\n' sprintf vars;&

gen=: {{ 

 object=:strings=:vars=:i.0
 gen_code load_ast y
 list_code gen_op halt

}}</lang>

Count example: <lang J> count=:{{)n count = 1; while (count < 10) { 

   print("count is: ", count, "\n");
   count = count + 1;

} }} 

  gen syntax lex count

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

</lang>

Java

Translation of: Python

<lang java>package codegenerator;

import java.io.File; import java.util.ArrayList; import java.util.Arrays; import java.util.HashMap; import java.util.List; import java.util.Map; import java.util.Scanner;

public class CodeGenerator { 

   final static int WORDSIZE = 4;
   
   static byte[] code = {};
   
   static Map<String, NodeType> str_to_nodes = new HashMap<>();
   static List<String> string_pool = new ArrayList<>();
   static List<String> variables = new ArrayList<>();
   static int string_count = 0;
   static int var_count = 0;
   
   static Scanner s;
   static NodeType[] unary_ops = {
       NodeType.nd_Negate, NodeType.nd_Not
   };
   static NodeType[] operators = {
       NodeType.nd_Mul, NodeType.nd_Div, NodeType.nd_Mod, NodeType.nd_Add, NodeType.nd_Sub,
       NodeType.nd_Lss, NodeType.nd_Leq, NodeType.nd_Gtr, NodeType.nd_Geq,
       NodeType.nd_Eql, NodeType.nd_Neq, NodeType.nd_And, NodeType.nd_Or
   };

   static enum Mnemonic {
       NONE, FETCH, STORE, PUSH, ADD, SUB, MUL, DIV, MOD, LT, GT, LE, GE, EQ, NE, AND, OR, NEG, NOT,
       JMP, JZ, PRTC, PRTS, PRTI, HALT
   }
   static class Node {
       public NodeType nt;
       public Node left, right;
       public String value;

       Node() {
           this.nt = null;
           this.left = null;
           this.right = null;
           this.value = null;
       }
       Node(NodeType node_type, Node left, Node right, String value) {
           this.nt = node_type;
           this.left = left;
           this.right = right;
           this.value = value;
       }
       public static Node make_node(NodeType nodetype, Node left, Node right) {
           return new Node(nodetype, left, right, "");
       }
       public static Node make_node(NodeType nodetype, Node left) {
           return new Node(nodetype, left, null, "");
       }
       public static Node make_leaf(NodeType nodetype, String value) {
           return new Node(nodetype, null, null, value);
       }
   }
   static enum NodeType {
       nd_None("", Mnemonic.NONE), nd_Ident("Identifier", Mnemonic.NONE), nd_String("String", Mnemonic.NONE), nd_Integer("Integer", Mnemonic.NONE), nd_Sequence("Sequence", Mnemonic.NONE),
       nd_If("If", Mnemonic.NONE),
       nd_Prtc("Prtc", Mnemonic.NONE), nd_Prts("Prts", Mnemonic.NONE), nd_Prti("Prti", Mnemonic.NONE), nd_While("While", Mnemonic.NONE),
       nd_Assign("Assign", Mnemonic.NONE),
       nd_Negate("Negate", Mnemonic.NEG), nd_Not("Not", Mnemonic.NOT), nd_Mul("Multiply", Mnemonic.MUL), nd_Div("Divide", Mnemonic.DIV), nd_Mod("Mod", Mnemonic.MOD), nd_Add("Add", Mnemonic.ADD),
       nd_Sub("Subtract", Mnemonic.SUB), nd_Lss("Less", Mnemonic.LT), nd_Leq("LessEqual", Mnemonic.LE),
       nd_Gtr("Greater", Mnemonic.GT), nd_Geq("GreaterEqual", Mnemonic.GE), nd_Eql("Equal", Mnemonic.EQ),
       nd_Neq("NotEqual", Mnemonic.NE), nd_And("And", Mnemonic.AND), nd_Or("Or", Mnemonic.OR);

       private final String name;
       private final Mnemonic m;

       NodeType(String name, Mnemonic m) {
           this.name = name;
           this.m = m;
       }
       Mnemonic getMnemonic() { return this.m; }

       @Override
       public String toString() { return this.name; }
   }
   static void appendToCode(int b) {
       code = Arrays.copyOf(code, code.length + 1);
       code[code.length - 1] = (byte) b;
   }
   static void emit_byte(Mnemonic m) {
       appendToCode(m.ordinal());
   }
   static void emit_word(int n) {
       appendToCode(n >> 24);
       appendToCode(n >> 16);
       appendToCode(n >> 8);
       appendToCode(n);
   }
   static void emit_word_at(int pos, int n) {
       code[pos] = (byte) (n >> 24);
       code[pos + 1] = (byte) (n >> 16);
       code[pos + 2] = (byte) (n >> 8);
       code[pos + 3] = (byte) n;
   }
   static int get_word(int pos) {
       int result;
       result = ((code[pos] & 0xff) << 24) + ((code[pos + 1] & 0xff)  << 16) + ((code[pos + 2] & 0xff)  << 8) + (code[pos + 3] & 0xff) ;
       
       return result;
   }
   static int fetch_var_offset(String name) {
       int n;
       n = variables.indexOf(name);
       if (n == -1) {
           variables.add(name);
           n = var_count++;
       }
       return n;
   }
   static int fetch_string_offset(String str) {
       int n;
       n = string_pool.indexOf(str);
       if (n == -1) {
           string_pool.add(str);
           n = string_count++;
       }
       return n;
   }
   static int hole() {
       int t = code.length;
       emit_word(0);
       return t;
   }
   static boolean arrayContains(NodeType[] a, NodeType n) {
       boolean result = false;
       for (NodeType test: a) {
           if (test.equals(n)) {
               result = true;
               break;
           }
       }
       return result;
   }
   static void code_gen(Node x) throws Exception {
       int n, p1, p2;
       if (x == null) return;
       
       switch (x.nt) {
           case nd_None: return;
           case nd_Ident:
               emit_byte(Mnemonic.FETCH);
               n = fetch_var_offset(x.value);
               emit_word(n);
               break;
           case nd_Integer:
               emit_byte(Mnemonic.PUSH);
               emit_word(Integer.parseInt(x.value));
               break;
           case nd_String:
               emit_byte(Mnemonic.PUSH);
               n = fetch_string_offset(x.value);
               emit_word(n);
               break;
           case nd_Assign:
               n = fetch_var_offset(x.left.value);
               code_gen(x.right);
               emit_byte(Mnemonic.STORE);
               emit_word(n);
               break;
           case nd_If:
               p2 = 0; // to avoid NetBeans complaining about 'not initialized'
               code_gen(x.left);
               emit_byte(Mnemonic.JZ);
               p1 = hole();
               code_gen(x.right.left);
               if (x.right.right != null) {
                   emit_byte(Mnemonic.JMP);
                   p2 = hole();
               }
               emit_word_at(p1, code.length - p1);
               if (x.right.right != null) {
                   code_gen(x.right.right);
                   emit_word_at(p2, code.length - p2);
               }
               break;
           case nd_While:
               p1 = code.length;
               code_gen(x.left);
               emit_byte(Mnemonic.JZ);
               p2 = hole();
               code_gen(x.right);
               emit_byte(Mnemonic.JMP);
               emit_word(p1 - code.length);
               emit_word_at(p2, code.length - p2);
               break;
           case nd_Sequence:
               code_gen(x.left);
               code_gen(x.right);
               break;
           case nd_Prtc:
               code_gen(x.left);
               emit_byte(Mnemonic.PRTC);
               break;
           case nd_Prti:
               code_gen(x.left);
               emit_byte(Mnemonic.PRTI);
               break;
           case nd_Prts:
               code_gen(x.left);
               emit_byte(Mnemonic.PRTS);
               break;
           default:
               if (arrayContains(operators, x.nt)) {
                   code_gen(x.left);
                   code_gen(x.right);
                   emit_byte(x.nt.getMnemonic());
               } else if (arrayContains(unary_ops, x.nt)) {
                   code_gen(x.left);
                   emit_byte(x.nt.getMnemonic());
               } else {
                   throw new Exception("Error in code generator! Found " + x.nt + ", expecting operator.");
               }
       }
   }
   static void list_code() throws Exception {
       int pc = 0, x;
       Mnemonic op;
       System.out.println("Datasize: " + var_count + " Strings: " + string_count);
       for (String s: string_pool) {
           System.out.println(s);
       }
       while (pc < code.length) {
           System.out.printf("%4d ", pc);
           op = Mnemonic.values()[code[pc++]];
           switch (op) {
               case FETCH:
                   x = get_word(pc);
                   System.out.printf("fetch [%d]", x);
                   pc += WORDSIZE;
                   break;
               case STORE:
                   x = get_word(pc);
                   System.out.printf("store [%d]", x);
                   pc += WORDSIZE;
                   break;
               case PUSH:
                   x = get_word(pc);
                   System.out.printf("push  %d", x);
                   pc += WORDSIZE;
                   break;
               case ADD: case SUB: case MUL: case DIV: case MOD:
               case LT: case GT: case LE: case GE: case EQ: case NE:
               case AND: case OR: case NEG: case NOT:
               case PRTC: case PRTI: case PRTS: case HALT:
                   System.out.print(op.toString().toLowerCase());
                   break;
               case JMP:
                   x = get_word(pc);
                   System.out.printf("jmp     (%d) %d", x, pc + x);
                   pc += WORDSIZE;
                   break;
               case JZ:
                   x = get_word(pc);
                   System.out.printf("jz      (%d) %d", x, pc + x);
                   pc += WORDSIZE;
                   break;
               default:
                   throw new Exception("Unknown opcode " + code[pc] + "@" + (pc - 1));
           }
           System.out.println();
       }
   }
   static Node load_ast() throws Exception {
       String command, value;
       String line;
       Node left, right;

       while (s.hasNext()) {
           line = s.nextLine();
           value = null;
           if (line.length() > 16) {
               command = line.substring(0, 15).trim();
               value = line.substring(15).trim();
           } else {
               command = line.trim();
           }
           if (command.equals(";")) {
               return null;
           }
           if (!str_to_nodes.containsKey(command)) {
               throw new Exception("Command not found: '" + command + "'");
           }
           if (value != null) {
               return Node.make_leaf(str_to_nodes.get(command), value);
           }
           left = load_ast(); right = load_ast();
           return Node.make_node(str_to_nodes.get(command), left, right);
       }
       return null; // for the compiler, not needed
   }
   public static void main(String[] args) {
       Node n;

       str_to_nodes.put(";", NodeType.nd_None);
       str_to_nodes.put("Sequence", NodeType.nd_Sequence);
       str_to_nodes.put("Identifier", NodeType.nd_Ident);
       str_to_nodes.put("String", NodeType.nd_String);
       str_to_nodes.put("Integer", NodeType.nd_Integer);
       str_to_nodes.put("If", NodeType.nd_If);
       str_to_nodes.put("While", NodeType.nd_While);
       str_to_nodes.put("Prtc", NodeType.nd_Prtc);
       str_to_nodes.put("Prts", NodeType.nd_Prts);
       str_to_nodes.put("Prti", NodeType.nd_Prti);
       str_to_nodes.put("Assign", NodeType.nd_Assign);
       str_to_nodes.put("Negate", NodeType.nd_Negate);
       str_to_nodes.put("Not", NodeType.nd_Not);
       str_to_nodes.put("Multiply", NodeType.nd_Mul);
       str_to_nodes.put("Divide", NodeType.nd_Div);
       str_to_nodes.put("Mod", NodeType.nd_Mod);
       str_to_nodes.put("Add", NodeType.nd_Add);
       str_to_nodes.put("Subtract", NodeType.nd_Sub);
       str_to_nodes.put("Less", NodeType.nd_Lss);
       str_to_nodes.put("LessEqual", NodeType.nd_Leq);
       str_to_nodes.put("Greater", NodeType.nd_Gtr);
       str_to_nodes.put("GreaterEqual", NodeType.nd_Geq);
       str_to_nodes.put("Equal", NodeType.nd_Eql);
       str_to_nodes.put("NotEqual", NodeType.nd_Neq);
       str_to_nodes.put("And", NodeType.nd_And);
       str_to_nodes.put("Or", NodeType.nd_Or);

       if (args.length > 0) {
           try {
               s = new Scanner(new File(args[0]));
               n = load_ast();
               code_gen(n);
               emit_byte(Mnemonic.HALT);
               list_code();
           } catch (Exception e) {
               System.out.println("Ex: "+e);//.getMessage());
           }
       }
   }

} </lang>

Julia

<lang julia>import Base.show

mutable struct Asm32 

   offset::Int32
   code::String
   arg::Int32
   targ::Int32

end Asm32(code, arg = 0) = Asm32(0, code, arg, 0)

show(io::IO, a::Asm32) = print(io, lpad("$(a.offset)", 6), lpad(a.code, 8), 

   a.targ > 0 ? (lpad("($(a.arg))", 8) * lpad("$(a.targ)", 4)) :
   (a.code in ["store", "fetch"] ? lpad("[$(a.arg)]", 8) :
   (a.code in ["push"] ? lpad("$(a.arg)", 8) : "")))

const ops32 = Dict{String,String}("Multiply" => "mul", "Divide" => "div", "Mod" => "mod", "Add" => "add", 

   "Subtract" => "sub", "Less" => "lt", "Greater" => "gt", "LessEqual" => "le", "GreaterEqual" => "ge",
   "Equal" => "eq", "NotEqual" => "ne", "And" => "and", "or" => "or", "Not" => "not", "Minus" => "neg",
   "Prtc" => "prtc", "Prti" => "prti", "Prts" => "prts")

function compiletoasm(io) 

   identifiers = Vector{String}()
   strings = Vector{String}()
   labels = Vector{Int}()

   function cpile(io, islefthandside = false)
       arr = Vector{Asm32}()
       jlabel() = (push!(labels, length(labels) + 1); labels[end])
       m = match(r"^(\w+|;)\s*([\d\w\"\\ \S]+)?", strip(readline(io)))
       x, val = m == nothing ? Pair(";", 0) : m.captures
       if x == ";" return arr
       elseif x == "Assign"
           lhs = cpile(io, true)
           rhs = cpile(io)
           append!(arr, rhs)
           append!(arr, lhs)
           if length(arr) > 100 exit() end
       elseif x == "Integer" push!(arr, Asm32("push", parse(Int32, val)))
       elseif x == "String"
           if !(val in strings)
               push!(strings, val)
           end
           push!(arr, Asm32("push", findfirst(x -> x == val, strings) - 1))
       elseif x == "Identifier"
           if !(val in identifiers)
               if !islefthandside
                   throw("Identifier $val referenced before it is assigned")
               end
               push!(identifiers, val)
           end
           push!(arr, Asm32(islefthandside ? "store" : "fetch", findfirst(x -> x == val, identifiers) - 1))
       elseif haskey(ops32, x)
           append!(arr, cpile(io))
           append!(arr, cpile(io))
           push!(arr, Asm32(ops32[x]))
       elseif x ==  "If"
           append!(arr, cpile(io))
           x, y = jlabel(), jlabel()
           push!(arr, Asm32("jz", x))
           append!(arr, cpile(io))
           push!(arr, Asm32("jmp", y))
           a = cpile(io)
           if length(a) < 1
               push!(a, Asm32("nop", 0))
           end
           a[1].offset = x
           append!(arr, a)
           push!(arr, Asm32(y, "nop", 0, 0)) # placeholder
       elseif x == "While"
           x, y = jlabel(), jlabel()
           a = cpile(io)
           if length(a) < 1
               push!(a, Asm32("nop", 0))
           end
           a[1].offset = x
           append!(arr, a)
           push!(arr, Asm32("jz", y))
           append!(arr, cpile(io))
           push!(arr, Asm32("jmp", x), Asm32(y, "nop", 0, 0))
       elseif x == "Sequence"
           append!(arr, cpile(io))
           append!(arr, cpile(io))
       else
           throw("unknown node type: $x")
       end
       arr
   end

   # compile AST
   asmarr = cpile(io)
   push!(asmarr, Asm32("halt"))
   # move address markers to working code and prune nop code
   for (i, acode) in enumerate(asmarr)
       if acode.code == "nop" && acode.offset != 0 && i < length(asmarr)
           asmarr[i + 1].offset = asmarr[i].offset
       end
   end
   filter!(x -> x.code != "nop", asmarr)
   # renumber offset column with actual offsets
   pos = 0
   jmps = Dict{Int, Int}()
   for acode in asmarr
       if acode.offset > 0
           jmps[acode.offset] = pos
       end
       acode.offset = pos
       pos += acode.code in ["push", "store", "fetch", "jz", "jmp"] ? 5 : 1
   end
   # fix up jump destinations
   for acode in asmarr
       if acode.code in ["jz", "jmp"]
           if haskey(jmps, acode.arg)
               acode.targ = jmps[acode.arg]
               acode.arg = acode.targ - acode.offset -1
           else
               throw("unknown jump location: $acode")
           end
       end
   end
   # print Datasize and Strings header
   println("Datasize: $(length(identifiers)) Strings: $(length(strings))\n" *
       join(strings, "\n") )
   # print assembly lines
   foreach(println, asmarr)

end

const testAST = raw""" 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 """

iob = IOBuffer(testAST) # use an io buffer here for testing, but could use stdin instead of iob

compiletoasm(iob)

</lang>

Output:


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

M2000 Interpreter

<lang M2000 Interpreter> Module CodeGenerator (s$){ Function code$(op$) { =format$("{0::-6} {1}", pc, op$) pc++ } Function code2$(op$, n$) { =format$("{0::-6} {1} {2}", pc, op$, n$) pc+=5 } Function code3$(op$,pc, st, ed) { =format$("{0::-6} {1} ({2}) {3}", pc, op$, ed-st-1, ed) }

Enum tok { gneg, gnot, gmul, gdiv, gmod, gadd, gle, gsub, glt gle, ggt, gge, geq, gne, gand, gor, gprtc, gprti, gprts, gif, gwhile, gAssign, gSeq, gstring, gidentifier, gint, gnone }

\\ Inventories are lists with keys, or keys/data (key must be unique) \\ there is one type more the Invetory Queue which get same keys. \\ But here not used. Inventory symb="Multiply":=gmul, "Divide":=gdiv, "Mod":=gmod, "Add":=gadd Append symb, "Negate":=gneg, "Not":=gnot,"Less":=glt,"Subtract":=gsub Append symb, "LessEqual":=gle, "Greater":=ggt, "GreaterEqual":=gge, "Sequence":=gSeq Append symb, "Equal":=geq, "NotEqual":=gne, "And":=gand, "Or":=gor, "While":=gwhile Append symb, "Prtc":=gprtc,"Prti":=gprti,"Prts":=gprts, "Assign":=gAssign, "If":=gif Append symb, "String":=gstring, "Identifier":=gidentifier, "Integer":=gint, ";", gnone

Inventory DataSet \\ We set string as key. key maybe an empty string, a string or a number. \\ so we want eash string to saved one time only. Inventory Strings

Const nl$=chr$(13)+chr$(10), Ansi=3 Def z$, lim, line$, newvar_ok, i=0 Document message$=nl$ Global pc \\ functions have own scope, so we make it global, for this module, and childs.

Dim lines$() s$=filter$(s$,chr$(9)) \\ exclude tabs Lines$()=piece$(s$,nl$) \\ break to lines lim=len(Lines$()) Flush ' empty stack (there is a current stack of values which we use here)

Load_Ast() If not stack.size=1 Then Flush : Error "Ast not loaded" AST=array \\ pop the array from stack Document Assembly$, Header$

\\ all lines of assembly goes to stack. Maybe not in right order. \\ Push statement push to top, Data statement push to bottom of stack

CodeGenerator(Ast) Data code$("halt") ' append to end of stack \\ So now we get all data (letters) from stack While not empty Assembly$=letter$+nl$ end while \\ So now we have to place them in order Sort Assembly$

\\ Let's make the header Header$=format$("Datasize: {0} Strings: {1}", Len(Dataset),Len(strings)) \\ we use an iterator object, str^ is the counter, readonly, but Eval$() use it from object. str=each(strings) While str Header$=nl$+Eval$(str) End while Assembly$=nl$ \\ insert to line 1 the Header Insert 1 Assembly$=Header$ \\ Also we check for warnings If len(message$)>2 then Assembly$="Warnings: "+nl$+message$ \\ So now we get a report \\ (at each 3/4 of window's lines, the printing stop and wait for user response, any key) Report Assembly$ Clipboard Assembly$ Save.Doc Assembly$, "code.t", Ansi End \\ subs have 10000 limit for recursion but can be extended to 1000000 or more. Sub CodeGenerator(t)

If len(t)=3 then select case t#val(0) Case gSeq CodeGenerator(t#val(1)) : CodeGenerator(t#val(2)) Case gwhile { local spc=pc CodeGenerator(t#val(1)) local pc1=pc pc+=5 ' room for jz CodeGenerator(t#val(2)) data code3$("jz",pc1, pc1, pc+5) data code3$("jmp",pc, pc, spc) pc+=5 ' room for jmp } Case gif { CodeGenerator(t#val(1)) local pc1=pc, pc2 pc+=5 CodeGenerator(t#val(2)#val(1)) If len(t#val(2)#val(2))>0 then pc2=pc pc+=5 data code3$("jz",pc1, pc1, pc) CodeGenerator(t#val(2)#val(2)) data code3$("jmp",pc2, pc2, pc) else data code3$("jz",pc1, pc1, pc) end If } Case gAssign { CodeGenerator(t#val(2)) local newvar_ok=true CodeGenerator(t#val(1)) } case gneg to gnot, gprtc to gprts CodeGenerator(t#val(1)) : data code$(mid$(eval$(t#val(0)),2)) case gmul to gor { CodeGenerator(t#val(1)) CodeGenerator(t#val(2)) data code$(mid$(eval$(t#val(0)),2)) } End select Else.if len(t)=2 then select case t#val(0) Case gString { local spos If exist(strings,t#val$(1)) then spos=eval(strings!) else append strings, t#val$(1) spos=len(strings)-1 end If Push code2$("push",str$(spos,0)) } Case gInt Push code2$("push",t#val$(1), pc) Case gIdentifier { local ipos If exist(dataset,t#val$(1)) then ipos=Eval(dataset!) ' return position else.if newvar_ok then Append dataset, t#val$(1) ipos=len(dataset)-1 else message$="Variable "+t#val$(1)+" not initialized"+nl$

end If If newvar_ok then Push code2$("store","["+str$(ipos, 0)+"]") else Push code2$("fetch","["+str$(ipos, 0)+"]") end If } end select End If End Sub Sub Load_Ast() If i>=lim then Push (,) : exit sub do line$=Trim$(lines$(i)) I++ tok$=piece$(line$," ")(0) until line$<>"" or i>=lim If tok$="Identifier" then Push (gidentifier,trim$(Mid$(line$,11))) else.if tok$="Integer" then long n=Val(Mid$(line$,8)) ' check overflow Push (gint, Trim$(Mid$(line$,8))) else.if tok$="String" then Push (gstring,Trim$(Mid$(line$,7))) else.if tok$=";" then Push (,) Else local otok=symb(tok$) Load_Ast() Load_Ast() Shift 2 Push (otok,array, array) End If End Sub }

CodeGenerator { 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 } </lang>

Output:
Datasize: 1 Strings: 2
"count is: "
"\n"
     0 push 
     5 store [0]
    10 fetch [0]
    15 push 
    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 
    54 add
    55 store [0]
    60 jmp (-51) 10
    65 halt

Nim

<lang Nim>import os, re, streams, strformat, strutils, tables, std/decls

type 

 # AST node types.
 NodeKind = enum
            nIdentifier = "Identifier"
            nString = "String"
            nInteger = "Integer"
            nSequence = "Sequence"
            nIf = "If"
            nPrtc = "Prtc"
            nPrts = "Prts"
            nPrti = "Prti"
            nWhile = "While"
            nAssign = "Assign"
            nNegate = "Negate"
            nNot = "Not"
            nMultiply = "Multiply"
            nDivide = "Divide"
            nMod = "Mod"
            nAdd = "Add"
            nSubtract = "Subtract"
            nLess = "Less"
            nLessEqual = "LessEqual"
            nGreater = "Greater"
            nGreaterEqual = "GreaterEqual"
            nEqual = "Equal"
            nNotEqual = "NotEqual"
            nAnd = "And"
            nOr = "Or"

 # Ast node description.
 Node = ref object
   left: Node
   right: Node
   case kind: NodeKind
   of nString: stringVal: string
   of nInteger: intVal: int
   of nIdentifier: name: string
   else: nil

 # Virtual machine opcodes.
 OpCode = enum
          opFetch = "fetch"
          opStore = "store"
          opPush = "push"
          opJmp = "jmp"
          opJz = "jz"
          opAdd = "add"
          opSub = "sub"
          opMul = "mul"
          opDiv = "div"
          opMod = "mod"
          opLt = "lt"
          opgt = "gt"
          opLe = "le"
          opGe = "ge"
          opEq = "eq"
          opNe = "ne"
          opAnd = "and"
          opOr = "or"
          opNeg = "neg"
          opNot = "not"
          opPrtc = "prtc"
          opPrti = "prti"
          opPrts = "prts"
          opHalt = "halt"
          opInvalid = "invalid"

 # Code generator context.
 CodeGen = object
   address: int              # Current address in code part.
   instr: seq[string]        # List of instructions.
   vars: Table[string, int]  # Mapping variable name -> variable index.
   strings: seq[string]      # List of strings.

 # Node ranges.
 UnaryOpNode = range[nNegate..nNot]
 BinaryOpNode = range[nMultiply..nOr]
 PrintNode = range[nPrtc..nPrti]


const 

 # Mapping unary operator Node -> OpCode.
 UnOp: array[UnaryOpNode, OpCode] = [opNeg, opNot]

 # Mapping binary operator Node -> OpCode.
 BinOp: array[BinaryOpNode, OpCode] = [opMul, opDiv, opMod, opAdd, opSub, opLt,
                                       opLe, opGt, opGe, opEq, opNe, opAnd, opOr]

 # Mapping print Node -> OpCode.
 PrintOp: array[PrintNode, OpCode] = [opPrtc, opPrts, opPrti]


  2. Code generator.

proc genSimpleInst(gen: var CodeGen; opcode: OpCode) = 

 ## Build a simple instruction (no operand).
 gen.instr.add &"{gen.address:>5} {opcode}"
  1. ---------------------------------------------------------------------------------------------------

proc genMemInst(gen: var CodeGen; opcode: OpCode; memIndex: int) = 

 ## Build a memory access instruction (opFetch, opStore).
 gen.instr.add &"{gen.address:>5} {opcode:<5} [{memIndex}]"
  1. ---------------------------------------------------------------------------------------------------

proc genJumpInst(gen: var CodeGen; opcode: OpCode): int = 

 ## Build a jump instruction. We use the letters X and Y as placeholders
 ## for the offset and the target address.
 result = gen.instr.len
 gen.instr.add &"{gen.address:>5} {opcode:<5} (X) Y"
  1. ---------------------------------------------------------------------------------------------------

proc genPush(gen: var CodeGen; value: int) = 

 ## Build a push instruction.
 gen.instr.add &"{gen.address:>5} {opPush:<5} {value}"
  1. ---------------------------------------------------------------------------------------------------

proc updateJumpInst(gen: var CodeGen; index: int; jumpAddress, targetAddress: int) = 

 ## Update the offset and the target address of a jump instruction.

 var instr {.byAddr.} = gen.instr[index]
 let offset = targetAddress - jumpAddress - 1
 for idx in countdown(instr.high, 0):
   case instr[idx]
   of 'Y':
     instr[idx..idx] = $targetAddress
   of 'X':
     instr[idx..idx] = $offset
     break
   else:
     discard
  1. ---------------------------------------------------------------------------------------------------

proc process(gen: var CodeGen; node: Node) = 

 ## Generate code for a node.

 if node.isNil: return

 case node.kind:

 of nInteger:
   gen.genPush(node.intVal)
   inc gen.address, 5

 of nIdentifier:
   if node.name notin gen.vars:
     gen.vars[node.name] = gen.vars.len
   gen.genMemInst(opFetch, gen.vars[node.name])
   inc gen.address, 5

 of nString:
   var index = gen.strings.find(node.stringVal)
   if index < 0:
     index = gen.strings.len
     gen.strings.add(node.stringVal)
   gen.genPush(index)
   inc gen.address, 5

 of nAssign:
   gen.process(node.right)
   if node.left.name notin gen.vars:
     gen.vars[node.left.name] = gen.vars.len
   gen.genMemInst(opStore, gen.vars[node.left.name])
   inc gen.address, 5

 of UnaryOpNode.low..UnaryOpNode.high:
   gen.process(node.left)
   gen.genSimpleInst(UnOp[node.kind])
   inc gen.address

 of BinaryOpNode.low..BinaryOpNode.high:
   gen.process(node.left)
   gen.process(node.right)
   gen.genSimpleInst(BinOp[node.kind])
   inc gen.address

 of PrintNode.low..PrintNode.high:
   gen.process(node.left)
   gen.genSimpleInst(PrintOp[node.kind])
   inc gen.address

 of nIf:
   # Generate condition expression.
   gen.process(node.left)
   # Generate jump if zero.
   let jzAddr = gen.address
   let jzInst = gen.genJumpInst(opJz)
   inc gen.address, 5
   # Generate then branch expression.
   gen.process(node.right.left)
   # If there is an "else" clause, generate unconditional jump
   var jmpAddr, jmpInst: int
   let hasElseClause = not node.right.right.isNil
   if hasElseClause:
     jmpAddr = gen.address
     jmpInst = gen.genJumpInst(opJmp)
     inc gen.address, 5
   # Update JZ offset.
   gen.updateJumpInst(jzInst, jzAddr, gen.address)
   # Generate else expression.
   if hasElseClause:
     gen.process(node.right.right)
     # Update JMP offset.
     gen.updateJumpInst(jmpInst, jmpAddr, gen.address)

 of nWhile:
   let condAddr = gen.address
   # Generate condition expression.
   gen.process(node.left)
   # Generate jump if zero.
   let jzAddr = gen.address
   let jzInst = gen.genJumpInst(opJz)
   inc gen.address, 5
   # Generate loop code.
   gen.process(node.right)
   # Generate unconditional jump.
   let jmpAddr = gen.address
   let jmpInst = gen.genJumpInst(opJmp)
   inc gen.address, 5
   # Update JMP offset.
   gen.updateJumpInst(jmpInst, jmpAddr, condAddr)
   # Update JZ offset.
   gen.updateJumpInst(jzInst, jzAddr, gen.address)

 of nSequence:
   gen.process(node.left)
   gen.process(node.right)
  1. ---------------------------------------------------------------------------------------------------

proc run(gen: var CodeGen; ast: Node) = 

 ## Run the code generator on the AST.

 # Process recursively the nodes.
 gen.process(ast)
 gen.genSimpleInst(opHalt)   # Add a Halt operator at the end.

 # Output header.
 echo &"Datasize: {gen.vars.len} Strings: {gen.strings.len}"
 # Output strings.
 for s in gen.strings:
   echo s.escape().replace("\\x0A", "\\n")
 # Output code.
 for inst in gen.instr:
   echo inst
  2. AST loader.

proc newNode(kind: NodeKind; left: Node; right: Node = nil): Node = 

 ## Create a new node with given left and right children.
 result = Node(kind: kind, left: left, right: right)
  1. ---------------------------------------------------------------------------------------------------

proc loadAst(stream: Stream): Node = 

 ## Load a linear AST and build a binary tree.

 let line = stream.readLine().strip()
 if line.startsWith(';'):
   return nil

 var fields = line.split(' ', 1)
 let kind = parseEnum[NodeKind](fields[0])
 if kind in {nIdentifier, nString, nInteger}:
   if fields.len < 2:
     raise newException(ValueError, "Missing value field for " & fields[0])
   else:
     fields[1] = fields[1].strip()
 case kind
 of nIdentifier:
   return Node(kind: nIdentifier, name: fields[1])
 of nString:
   let str = fields[1].replacef(re"([^\\])(\\n)", "$1\n").replace(r"\\", r"\").replace("\"", "")
   return Node(kind: nString, stringVal: str)
 of nInteger:
   return Node(kind: nInteger, intVal: parseInt(fields[1]))
 else:
   if fields.len > 1:
     raise newException(ValueError, "Extra field for " & fields[0])

 let left = stream.loadAst()
 let right = stream.loadAst()
 result = newNode(kind, left, right)


  1. ———————————————————————————————————————————————————————————————————————————————————————————————————

var stream: Stream var toClose = false var codegen: CodeGen

if paramCount() < 1: 

 stream = newFileStream(stdin)

else: 

 stream = newFileStream(paramStr(1))
 toClose = true

let ast = loadAst(stream) if toClose: stream.close()

codegen.run(ast)</lang>

Output:

The code produced is compliant with the specification and can be executed by the virtual machine interpreter. Example with ASCII Mandelbrot (https://rosettacode.org/wiki/Compiler/Sample_programs#Ascii_Mandlebrot). 

Datasize: 15 Strings: 0
    0 push  420
    5 neg
    6 store [0]
   11 push  300
   16 store [1]
   21 push  300
   26 store [2]
   31 push  300
   36 neg
   37 store [3]
   42 push  7
   47 store [4]
   52 push  15
   57 store [5]
   62 push  200
   67 store [6]
   72 fetch [2]
   77 store [7]
   82 fetch [7]
   87 fetch [3]
   92 gt
   93 jz    (329) 423
   98 fetch [0]
  103 store [8]
  108 fetch [8]
  113 fetch [1]
  118 lt
  119 jz    (276) 396
  124 push  0
  129 store [9]
  134 push  0
  139 store [10]
  144 push  32
  149 store [11]
  154 push  0
  159 store [12]
  164 fetch [12]
  169 fetch [6]
  174 lt
  175 jz    (193) 369
  180 fetch [10]
  185 fetch [10]
  190 mul
  191 push  200
  196 div
  197 store [13]
  202 fetch [9]
  207 fetch [9]
  212 mul
  213 push  200
  218 div
  219 store [14]
  224 fetch [13]
  229 fetch [14]
  234 add
  235 push  800
  240 gt
  241 jz    (56) 298
  246 push  48
  251 fetch [12]
  256 add
  257 store [11]
  262 fetch [12]
  267 push  9
  272 gt
  273 jz    (14) 288
  278 push  64
  283 store [11]
  288 fetch [6]
  293 store [12]
  298 fetch [10]
  303 fetch [9]
  308 mul
  309 push  100
  314 div
  315 fetch [7]
  320 add
  321 store [9]
  326 fetch [13]
  331 fetch [14]
  336 sub
  337 fetch [8]
  342 add
  343 store [10]
  348 fetch [12]
  353 push  1
  358 add
  359 store [12]
  364 jmp   (-201) 164
  369 fetch [11]
  374 prtc
  375 fetch [8]
  380 fetch [4]
  385 add
  386 store [8]
  391 jmp   (-284) 108
  396 push  10
  401 prtc
  402 fetch [7]
  407 fetch [5]
  412 sub
  413 store [7]
  418 jmp   (-337) 82
  423 halt

Perl

Tested with perl v5.26.1 <lang Perl>#!/usr/bin/perl

use strict; # gen.pl - flatAST to stack machine code use warnings; # http://www.rosettacode.org/wiki/Compiler/code_generator

my $stringcount = my $namecount = my $pairsym = my $pc = 0; my (%strings, %names); my %opnames = qw( Less lt LessEqual le Multiply mul Subtract sub Divide div 

 GreaterEqual ge Equal eq Greater gt NotEqual ne Negate neg );

sub tree 

 {
 my ($A, $B) = ( '_' . ++$pairsym, '_' . ++$pairsym ); # labels for jumps
 my $line = <> // return ;
 (local $_, my $arg) = $line =~ /^(\w+|;)\s+(.*)/ or die "bad input $line";
 /Identifier/ ? "fetch [@{[ $names{$arg} //= $namecount++ ]}]\n" :
   /Sequence/ ? tree() . tree() :
   /Integer/  ? "push  $arg\n" :
   /String/   ? "push  @{[ $strings{$arg} //= $stringcount++ ]}\n" :
   /Assign/   ? join , reverse tree() =~ s/fetch/store/r, tree() :
   /While/    ? "$A:\n@{[ tree() ]}jz    $B\n@{[ tree() ]}jmp   $A\n$B:\n" :
   /If/       ? tree() . "jz    $A\n@{[ !<> . # !<> skips second 'If'
                 tree() ]}jmp   $B\n$A:\n@{[ tree() ]}$B:\n" :
   /;/        ?  :
   tree() . tree() . ($opnames{$_} // lc) . "\n";
 }

$_ = tree() . "halt\n";

s/^jmp\s+(\S+)\n(_\d+:\n)\1:\n/$2/gm; # remove jmp next s/^(?=[a-z]\w*(.*))/ # add locations 

 (sprintf("%4d ", $pc), $pc += $1 ? 5 : 1)[0] /gem;

my %labels = /^(_\d+):(?=(?:\n_\d+:)*\n *(\d+) )/gm; # pc addr of labels s/^ *(\d+) j(?:z|mp) *\K(_\d+)$/ (@{[ # fix jumps 

 $labels{$2} - $1 - 1]}) $labels{$2}/gm;

s/^_\d+.*\n//gm; # remove labels

print "Datasize: $namecount Strings: $stringcount\n"; print "$_\n" for sort { $strings{$a} <=> $strings{$b} } keys %strings; print;</lang> Passes all tests.

Phix

Reusing parse.e from the Syntax Analyzer task
Deviates somewhat from the task specification in that it generates executable machine code. 

--
-- demo\rosetta\Compiler\cgen.e
-- ============================
--
--  The reusable part of cgen.exw
--
without js -- (machine code!)
include parse.e

global sequence vars = {},
                strings = {},
                stringptrs = {}

global integer chain = 0
global sequence code = {}

function var_idx(sequence inode)
    if inode[1]!=tk_Identifier then ?9/0 end if
    string ident = inode[2]
    integer n = find(ident,vars)
    if n=0 then
        vars = append(vars,ident)
        n = length(vars)
    end if
    return n
end function

function string_idx(sequence inode)
    if inode[1]!=tk_String then ?9/0 end if
    string s = inode[2]
    integer n = find(s,strings)
    if n=0 then
        strings = append(strings,s)
        stringptrs = append(stringptrs,0)
        n = length(strings)
    end if
    return n
end function

function gen_size(object t)
-- note: must be kept precisely in sync with gen_rec!
--        (relentlessly tested via estsize/actsize)
integer size = 0
    if t!=NULL then
        integer n_type = t[1]
        string node_type = tkNames[n_type]
        switch n_type do
            case tk_Sequence:
                size += gen_size(t[2])
                size += gen_size(t[3])
            case tk_assign:
                size += gen_size(t[3])+6
            case tk_Integer:
                size += 5
            case tk_Identifier:
                size += 6
            case tk_String:
                size += 5
            case tk_while:
                -- emit: @@:<condition><topjmp(@f)><body><tailjmp(@b)>@@:
                size += gen_size(t[2])+3
                integer body = gen_size(t[3])
                integer stail = iff(size+body+2>128?5:2)
                integer stop  = iff(body+stail >127?6:2)
                size += stop+body+stail
            case tk_lt:
            case tk_le:
            case tk_ne:
            case tk_eq:
            case tk_gt:
            case tk_ge:
                size += gen_size(t[2])
                size += gen_size(t[3])
                size += 10
            case tk_and:
            case tk_or:
                size += gen_size(t[2])
                size += gen_size(t[3])
                size += 15
            case tk_add:
            case tk_sub:
                size += gen_size(t[2])
                size += gen_size(t[3])
                size += 4
            case tk_mul:
                size += gen_size(t[2])
                size += gen_size(t[3])
                size += 5
            case tk_div:
            case tk_mod:
                size += gen_size(t[2])
                size += gen_size(t[3])
                size += 6
            case tk_putc:
            case tk_Printi:
            case tk_Prints:
                size += gen_size(t[2])
                size += 5
            case tk_if:
                size += gen_size(t[2])+3
                if t[3][1]!=tk_if then ?9/0 end if
                integer truesize = gen_size(t[3][2])
                integer falsesize = gen_size(t[3][3])
                integer elsejmp = iff(falsesize=0?0:iff(falsesize>127?5:2))
                integer mainjmp = iff(truesize+elsejmp>127?6:2)
                size += mainjmp+truesize+elsejmp+falsesize
            case tk_not:
                size += gen_size(t[2])
                size += 9
            case tk_neg:
                size += gen_size(t[2])
                size += 4
            else:
                ?9/0
        end switch
    end if
    return size
end function

procedure gen_rec(object t)
-- the recursive part of code_gen
    if t!=NULL then
        integer initsize = length(code)
        integer estsize = gen_size(t)   -- (test the gen_size function)
        integer n_type = t[1]
        string node_type = tkNames[n_type]
        switch n_type do
            case tk_Sequence:
                gen_rec(t[2])
                gen_rec(t[3])
            case tk_assign:
                integer n = var_idx(t[2])
                gen_rec(t[3])
                code &= {0o217,0o005,chain,1,n,0}   -- pop [i]
                chain = length(code)-3
            case tk_Integer:
                integer n = t[2]
                code &= 0o150&int_to_bytes(n)       -- push imm32
            case tk_while:
                -- emit: @@:<condition><topjmp(@f)><body><tailjmp(@b)>@@:
                integer looptop = length(code)
                gen_rec(t[2])
                code &= {0o130,                                 -- pop eax
                         0o205,0o300}                           -- test eax,eax
                integer bodysize = gen_size(t[3])
                -- can we use short jumps?
                -- disclaimer: size calcs are not heavily tested; if in
                --             doubt reduce 128/7 by 8, and if that works
                --             then yep, you just found a boundary case.
                integer stail = iff(length(code)+bodysize+4-looptop>128?5:2)
                integer offset = bodysize+stail
                integer stop  = iff(offset>127?6:2)
                if stop=2 then
                    code &= {0o164,offset}                      -- jz (short) end
                else
                    code &= {0o017,0o204}&int_to_bytes(offset)  -- jz (long) end
                end if
                gen_rec(t[3])
                offset = looptop-(length(code)+stail)
                if stail=2 then
                    code &= 0o353&offset                        -- jmp looptop (short)
                else
                    code &= 0o351&int_to_bytes(offset)          -- jmp looptop (long)
                end if
            case tk_lt:
            case tk_le:
            case tk_gt:
            case tk_ge:
            case tk_ne:
            case tk_eq:
                gen_rec(t[2])
                gen_rec(t[3])
                integer xrm
                if    n_type=tk_ne then xrm = 0o225 -- (#95)
                elsif n_type=tk_lt then xrm = 0o234 -- (#9C)
                elsif n_type=tk_ge then xrm = 0o235 -- (#9D)
                elsif n_type=tk_le then xrm = 0o236 -- (#9E)
                elsif n_type=tk_gt then xrm = 0o237 -- (#9F)
                else ?9/0
                end if
                code &= { 0o061,0o300,                          -- xor eax,eax
                          0o132,                                -- pop edx
                          0o131,                                -- pop ecx
                          0o071,0o321,                          -- cmp ecx,edx
                          0o017,xrm,0o300,                      -- setcc al
                          0o120}                                -- push eax
            case tk_or:
            case tk_and:
                gen_rec(t[2])
                gen_rec(t[3])
                integer op = find(n_type,{tk_or,0,0,tk_and})
                op *= 0o010
                code &= { 0o130,                                -- pop eax
                          0o131,                                -- pop ecx
                          0o205,0o300,                          -- test eax,eax
                          0o017,0o225,0o300,                    -- setne al
                          0o205,0o311,                          -- test ecx,ecx
                          0o017,0o225,0o301,                    -- setne cl
                          op,0o310,                             -- or/and al,cl
                          0o120}                                -- push eax
            case tk_add:
            case tk_sub:
                gen_rec(t[2])
                gen_rec(t[3])
                integer op = find(n_type,{tk_add,0,0,0,0,tk_sub})
                op = 0o001 + (op-1)*0o010
                code &= { 0o130,                                -- pop eax
                          op,0o004,0o044}                       -- add/or/and/sub [esp],eax
            case tk_mul:
                gen_rec(t[2])
                gen_rec(t[3])
                code &= { 0o131,                                -- pop ecx
                          0o130,                                -- pop eax
                          0o367,0o341,                          -- mul ecx
                          0o120}                                -- push eax
            case tk_div:
            case tk_mod:
                gen_rec(t[2])
                gen_rec(t[3])
                integer push = 0o120+(n_type=tk_mod)*2
                code &= { 0o131,                                -- pop ecx
                          0o130,                                -- pop eax
                          0o231,                                -- cdq (eax -> edx:eax)
                          0o367,0o371,                          -- idiv ecx
                          push}                                 -- push eax|edx
            case tk_Identifier:
                integer n = var_idx(t)
                code &= {0o377,0o065,chain,1,n,0}               -- push [n]
                chain = length(code)-3
            case tk_putc:
            case tk_Printi:
            case tk_Prints:
                gen_rec(t[2])
                integer n = find(n_type,{tk_putc,tk_Printi,tk_Prints})
                code &= {0o350,chain,3,n,0}                     -- call :printc/i/s
                chain = length(code)-3
            case tk_String:
                integer n = string_idx(t)
                code &= {0o150,chain,2,n,0}                     -- push RawStringPtr(string)
                chain = length(code)-3
            case tk_if:
                -- emit: <condition><mainjmp><truepart>[<elsejmp><falsepart>]
                gen_rec(t[2])
                code &= {0o130,                                 -- pop eax
                         0o205,0o300}                           -- test eax,eax
                if t[3][1]!=tk_if then ?9/0 end if
                integer truesize = gen_size(t[3][2])
                integer falsesize = gen_size(t[3][3])
                integer elsejmp = iff(falsesize=0?0:iff(falsesize>127?5:2))
                integer offset = truesize+elsejmp
                integer mainjmp = iff(offset>127?6:2)
                if mainjmp=2 then
                    code &= {0o164,offset}                      -- jz (short) else/end
                else
                    code &= {0o017,0o204}&int_to_bytes(offset)  -- jz (long) else/end
                end if
                gen_rec(t[3][2])
                if falsesize!=0 then
                    offset = falsesize
                    if elsejmp=2 then
                        code &= 0o353&offset                    -- jmp end if (short)
                    else
                        code &= 0o351&int_to_bytes(offset)      -- jmp end if (long)
                    end if
                    gen_rec(t[3][3])
                end if
            case tk_not:
                gen_rec(t[2])
                code &= {0o132,                                 -- pop edx
                         0o061,0o300,                           -- xor eax,eax
                         0o205,0o322,                           -- test edx,edx
                         0o017,0o224,0o300,                     -- setz al
                         0o120}                                 -- push eax
            case tk_neg:
                gen_rec(t[2])
                code &= {0o130,                             -- pop eax
                         0o367,0o330,                       -- neg eax
                         0o120}                             -- push eax
            else:
                error("error in code generator - found %d, expecting operator\n", {n_type})
        end switch
        integer actsize = length(code)
        if initsize+estsize!=actsize then ?"9/0" end if -- (test gen_size)
    end if
end procedure

global procedure code_gen(object t)
--
-- Generates proper machine code.
--
-- Example: i=10; print "\n"; print i; print "\n"
-- Result in vars, strings, chain, code (declared above)
--    where vars is: {"i"},
--          strings is {"\n"},
--          code is { 0o150,#0A,#00,#00,#00,        -- 1: push 10
--                    0o217,0o005,0,1,1,0           -- 6: pop [i]
--                    0o150,8,2,1,0,                -- 12: push ("\n")
--                    0o350,13,3,3,0,               -- 17: call :prints
--                    0o377,0o065,18,1,1,0,         -- 22: push [i]
--                    0o350,24,3,2,0,               -- 28: call :printi
--                    0o150,29,2,1,0,               -- 33: push ("\n")
--                    0o350,34,3,3,0,               -- 38: call :prints
--                    0o303}                        -- 43: ret
--          and chain is 39 (->34->29->24->18->13->8->0)
-- The chain connects all places where we need an actual address before
--  the code is executed, with the byte after the link differentiating
--  between var(1), string(2), and builtin(3), and the byte after that
--  determining the instance of the given type - not that any of them 
--  are actually limited to a byte in the above intermediate form, and
--  of course the trailing 0 of each {link,type,id,0} is just there to
--  reserve the space we will need.
--
    gen_rec(t)
    code = append(code,0o303)   -- ret (0o303=#C3)
end procedure

include builtins/VM/puts1.e -- low-level console i/o routines

function setbuiltins()
atom printc,printi,prints
    #ilASM{ 
        jmp :setbuiltins
    ::printc
        lea edi,[esp+4]
        mov esi,1
        call :%puts1ediesi  -- (edi=raw text, esi=length)
        ret 4
    ::printi
        mov eax,[esp+4]
        push 0              -- no cr
        call :%putsint      -- (nb limited to +/-9,999,999,999)
        ret 4
    ::prints
        mov edi,[esp+4]
        mov esi,[edi-12]
        call :%puts1ediesi  -- (edi=raw text, esi=length)
        ret 4
    ::setbuiltins
        mov eax,:printc
        lea edi,[printc]
        call :%pStoreMint
        mov eax,:printi
        lea edi,[printi]
        call :%pStoreMint
        mov eax,:prints
        lea edi,[prints]
        call :%pStoreMint
          }
    return {printc,printi,prints}
end function

global constant builtin_names = {"printc","printi","prints"}
global constant builtins = setbuiltins()

global atom var_mem, code_mem

function RawStringPtr(integer n)    -- (based on IupRawStringPtr from pGUI.e)
--
-- Returns a raw string pointer for s, somewhat like allocate_string(s), but using the existing memory.
-- NOTE: The return is only valid as long as the value passed as the parameter remains in existence.
--
atom res
    string s = strings[n]
    #ilASM{
            mov eax,[s]
            lea edi,[res]
            shl eax,2
            call :%pStoreMint
          }
    stringptrs[n] = res
    return res
end function

global procedure fixup()
    var_mem = allocate(length(vars)*4)
    mem_set(var_mem,0,length(vars)*4)
    code_mem = allocate(length(code))
    poke(code_mem,code)
    while chain!=0 do
        integer this = chain
        chain = code[this]
        integer ftype = code[this+1]
        integer id = code[this+2]
        switch ftype do
            case 1: -- vars
                poke4(code_mem+this-1,var_mem+(id-1)*4)
            case 2: -- strings
                poke4(code_mem+this-1,RawStringPtr(id))
            case 3: -- builtins
                poke4(code_mem+this-1,builtins[id]-(code_mem+this+3))
        end switch
    end while
end procedure

And a simple test driver for the specific task: 

--
-- demo\rosetta\Compiler\cgen.exw
-- ==============================
--
--  Generates 32-bit machine code (see note in vm.exw)
--
without js -- (machine code!)
include cgen.e

function get_var_name(atom addr)
    integer n = (addr-var_mem)/4+1
    if n<1 or n>length(vars) then ?9/0 end if
    return vars[n]
end function

function hxl(integer pc, object oh, string fmt, sequence args={})
-- helper routine to display the octal/hex bytes just decoded,
-- along with the code offset and the human-readable text.
    if length(args) then fmt = sprintf(fmt,args) end if
    sequence octhex = {}
    atom base = code_mem+pc
    integer len = 0
    if integer(oh) then -- all octal
        for i=1 to oh do
            octhex = append(octhex,sprintf("0o%03o",peek(base)))
            base += 1
        end for
        len = oh
    else    -- some octal and some hex
        for i=1 to length(oh) by 2 do
            for j=1 to oh[i] do
                octhex = append(octhex,sprintf("0o%03o",peek(base)))
                base += 1
            end for
            len += oh[i]
            for j=1 to oh[i+1] do
                octhex = append(octhex,sprintf("#%02x",peek(base)))
                base += 1
            end for
            len += oh[i+1]
        end for
    end if
    printf(output_file,"%4d: %-30s %s\n",{pc+1,join(octhex,","),fmt})
    return len
end function

constant cccodes = {"o?" ,"no?","b?" ,"ae?","z" ,"ne" ,"be?","a?",
--                    0  ,  1  ,  2  ,  3  ,  4 ,  5  ,  6  , 7  ,
                    "s?" ,"ns?","pe?","po?","l" ,"ge" ,"le" ,"g" }
--                    8  ,  9  , 10  , 11  , 12 , 13  , 14  , 15

constant regs = {"eax","ecx","edx"} -- (others as/when needed)

procedure decode()
-- for a much more complete (and better organised) disassembler, see p2asm.e
integer pc = 0, -- nb 0-based
        opcode, xrm

    while pc<length(code) do
        opcode = peek(code_mem+pc)
        xrm = -1
        switch opcode do
            case 0o150:
                atom vaddr = peek4s(code_mem+pc+1)
                integer n = find(vaddr,stringptrs)
                object arg = iff(n?enquote(strings[n])
                                  :sprintf("%d",vaddr))
                pc += hxl(pc,{1,4},"push %s",{arg})
            case 0o217:
            case 0o377:
                integer n = find(opcode,{0o217,0o377})
                string op = {"pop","push"}[n]
                xrm = peek(code_mem+pc+1)
                if n!=find(xrm,{0o005,0o065}) then exit end if
                atom addr = peek4u(code_mem+pc+2)
                pc += hxl(pc,{2,4},"%s [%s]",{op,get_var_name(addr)})
            case 0o061:
            case 0o071:
            case 0o205:
                integer n = find(opcode,{0o061,0o071,0o205})
                string op = {"xor","cmp","test"}[n]
                xrm = peek(code_mem+pc+1)
                if and_bits(xrm,0o300)!=0o300 then exit end if
                string r1 = regs[and_bits(xrm,0o070)/0o010+1]
                string r2 = regs[and_bits(xrm,0o007)+1]
                pc += hxl(pc,2,"%s %s,%s",{op,r1,r2})
            case 0o017:
                xrm = peek(code_mem+pc+1)
                switch xrm do
                    case 0o224:
                    case 0o225:
                    case 0o234:
                    case 0o235:
                    case 0o236:
                    case 0o237:
                        string cc = cccodes[and_bits(xrm,0o017)+1]
                        xrm = peek(code_mem+pc+2)
                        if xrm=0o300 then
                            pc += hxl(pc,3,"set%s al",{cc})
                        elsif xrm=0o301 then
                            pc += hxl(pc,3,"set%s cl",{cc})
                        else
                            exit
                        end if
                    case 0o204:
                        integer offset = peek4s(code_mem+pc+2)
                        pc += hxl(pc,{2,4},"jz %d",{pc+6+offset+1})
                    else
                        exit
                end switch
            case 0o010:
            case 0o040:
                xrm = peek(code_mem+pc+1)
                if xrm=0o310 then
                    string lop = {"or","and"}[find(opcode,{0o010,0o040})]
                    pc += hxl(pc,2,"%s al,cl",{lop})
                else
                    exit
                end if
            case 0o120:
            case 0o122:
            case 0o130:
            case 0o131:
            case 0o132:
                string op = {"push","pop"}[find(and_bits(opcode,0o070),{0o020,0o030})]
                string reg = regs[and_bits(opcode,0o007)+1]
                pc += hxl(pc,1,"%s %s",{op,reg})
            case 0o231:
                pc += hxl(pc,1,"cdq")
            case 0o164:
            case 0o353:
                string jop = iff(opcode=0o164?"jz":"jmp")
                integer offset = peek1s(code_mem+pc+1)
                pc += hxl(pc,{1,1},"%s %d",{jop,pc+2+offset+1})
            case 0o351:
                integer offset = peek4s(code_mem+pc+1)
                pc += hxl(pc,{1,4},"jmp %d",{pc+5+offset+1})
            case 0o303:
                pc += hxl(pc,1,"ret")
            case 0o350:
                integer offset = peek4s(code_mem+pc+1)
                atom addr = offset+code_mem+pc+5
                integer n = find(addr,builtins)
                pc += hxl(pc,{1,4},"call :%s",{builtin_names[n]})
            case 0o001:
            case 0o041:
            case 0o051:
                integer n = find(opcode,{0o001,0o041,0o051})
                string op = {"add","and","sub"}[n]
                xrm = peek(code_mem+pc+1)
                switch xrm do
                    case 0o004:
                        if peek(code_mem+pc+2)=0o044 then
                            pc += hxl(pc,3,"%s [esp],eax",{op})
                        else
                            exit
                        end if
                    else
                        exit
                end switch
            case 0o367:
                xrm = peek(code_mem+pc+1)
                if and_bits(xrm,0o300)!=0o300 then exit end if
                integer n = find(and_bits(xrm,0o070),{0o030,0o040,0o070})
                if n=0 then exit end if
                string op = {"neg","mul","idiv"}[n]
                string reg = regs[and_bits(xrm,0o007)+1]
                pc += hxl(pc,2,"%s %s",{op,reg})
            else
                exit
        end switch
    end while
    if pc<length(code) then
        ?"incomplete:"
        if xrm=-1 then
            ?{pc+1,sprintf("0o%03o",opcode)}
        else
            ?{pc+1,sprintf("0o%03o 0o%03o",{opcode,xrm})}
        end if
    end if
end procedure

procedure main(sequence cl)
    open_files(cl)
    toks = lex()
    object t = parse()
    code_gen(t)
    fixup()
    decode()
    free({var_mem,code_mem})
    close_files()
end procedure

--main(command_line())
main({0,0,"gcd.c"})
Output:
   1: 0o150,#2F,#04,#00,#00          push 1071
   6: 0o217,0o005,#70,#BE,#73,#00    pop [a]
  12: 0o150,#05,#04,#00,#00          push 1029
  17: 0o217,0o005,#74,#BE,#73,#00    pop [b]
  23: 0o377,0o065,#74,#BE,#73,#00    push [b]
  29: 0o150,#00,#00,#00,#00          push 0
  34: 0o061,0o300                    xor eax,eax
  36: 0o132                          pop edx
  37: 0o131                          pop ecx
  38: 0o071,0o321                    cmp edx,ecx
  40: 0o017,0o225,0o300              setne al
  43: 0o120                          push eax
  44: 0o130                          pop eax
  45: 0o205,0o300                    test eax,eax
  47: 0o164,#32                      jz 99
  49: 0o377,0o065,#74,#BE,#73,#00    push [b]
  55: 0o217,0o005,#78,#BE,#73,#00    pop [new_a]
  61: 0o377,0o065,#70,#BE,#73,#00    push [a]
  67: 0o377,0o065,#74,#BE,#73,#00    push [b]
  73: 0o131                          pop ecx
  74: 0o130                          pop eax
  75: 0o231                          cdq
  76: 0o367,0o371                    idiv ecx
  78: 0o122                          push edx
  79: 0o217,0o005,#74,#BE,#73,#00    pop [b]
  85: 0o377,0o065,#78,#BE,#73,#00    push [new_a]
  91: 0o217,0o005,#70,#BE,#73,#00    pop [a]
  97: 0o353,#B4                      jmp 23
  99: 0o377,0o065,#70,#BE,#73,#00    push [a]
 105: 0o350,#2F,#49,#0B,#00          call :printi
 110: 0o303                          ret

Python

Tested with Python 2.7 and 3.x <lang Python>from __future__ import print_function import sys, struct, shlex, operator

nd_Ident, nd_String, nd_Integer, nd_Sequence, nd_If, nd_Prtc, nd_Prts, nd_Prti, nd_While, \ nd_Assign, nd_Negate, nd_Not, nd_Mul, nd_Div, nd_Mod, nd_Add, nd_Sub, nd_Lss, nd_Leq, \ nd_Gtr, nd_Geq, nd_Eql, nd_Neq, nd_And, nd_Or = range(25)

all_syms = { 

   "Identifier"  : nd_Ident,    "String"      : nd_String,
   "Integer"     : nd_Integer,  "Sequence"    : nd_Sequence,
   "If"          : nd_If,       "Prtc"        : nd_Prtc,
   "Prts"        : nd_Prts,     "Prti"        : nd_Prti,
   "While"       : nd_While,    "Assign"      : nd_Assign,
   "Negate"      : nd_Negate,   "Not"         : nd_Not,
   "Multiply"    : nd_Mul,      "Divide"      : nd_Div,
   "Mod"         : nd_Mod,      "Add"         : nd_Add,
   "Subtract"    : nd_Sub,      "Less"        : nd_Lss,
   "LessEqual"   : nd_Leq,      "Greater"     : nd_Gtr,
   "GreaterEqual": nd_Geq,      "Equal"       : nd_Eql,
   "NotEqual"    : nd_Neq,      "And"         : nd_And,
   "Or"          : nd_Or}

FETCH, STORE, PUSH, ADD, SUB, MUL, DIV, MOD, LT, GT, LE, GE, EQ, NE, AND, OR, NEG, NOT, \ JMP, JZ, PRTC, PRTS, PRTI, HALT = range(24)

operators = {nd_Lss: LT, nd_Gtr: GT, nd_Leq: LE, nd_Geq: GE, nd_Eql: EQ, nd_Neq: NE, 

   nd_And: AND, nd_Or: OR, nd_Sub: SUB, nd_Add: ADD, nd_Div: DIV, nd_Mul: MUL, nd_Mod: MOD}

unary_operators = {nd_Negate: NEG, nd_Not: NOT}

input_file = None code = bytearray() string_pool = {} globals = {} string_n = 0 globals_n = 0 word_size = 4

        • show error and exit

def error(msg): 

   print("%s" % (msg))
   exit(1)

def int_to_bytes(val): 

   return struct.pack("<i", val)

def bytes_to_int(bstr): 

   return struct.unpack("<i", bstr)

class Node: 

   def __init__(self, node_type, left = None, right = None, value = None):
       self.node_type  = node_type
       self.left  = left
       self.right = right
       self.value = value

def make_node(oper, left, right = None): 

   return Node(oper, left, right)

def make_leaf(oper, n): 

   return Node(oper, value = n)

def emit_byte(x): 

   code.append(x)

def emit_word(x): 

   s = int_to_bytes(x)
   for x in s:
       code.append(x)

def emit_word_at(at, n): 

   code[at:at+word_size] = int_to_bytes(n)

def hole(): 

   t = len(code)
   emit_word(0)
   return t

def fetch_var_offset(name): 

   global globals_n

   n = globals.get(name, None)
   if n == None:
       globals[name] = globals_n
       n = globals_n
       globals_n += 1
   return n

def fetch_string_offset(the_string): 

   global string_n

   n = string_pool.get(the_string, None)
   if n == None:
       string_pool[the_string] = string_n
       n = string_n
       string_n += 1
   return n

def code_gen(x): 

   if x == None: return
   elif x.node_type == nd_Ident:
       emit_byte(FETCH)
       n = fetch_var_offset(x.value)
       emit_word(n)
   elif x.node_type == nd_Integer:
       emit_byte(PUSH)
       emit_word(x.value)
   elif x.node_type == nd_String:
       emit_byte(PUSH)
       n = fetch_string_offset(x.value)
       emit_word(n)
   elif x.node_type == nd_Assign:
       n = fetch_var_offset(x.left.value)
       code_gen(x.right)
       emit_byte(STORE)
       emit_word(n)
   elif x.node_type == nd_If:
       code_gen(x.left)              # expr
       emit_byte(JZ)                 # if false, jump
       p1 = hole()                   # make room for jump dest
       code_gen(x.right.left)        # if true statements
       if (x.right.right != None):
           emit_byte(JMP)            # jump over else statements
           p2 = hole()
       emit_word_at(p1, len(code) - p1)
       if (x.right.right != None):
           code_gen(x.right.right)   # else statements
           emit_word_at(p2, len(code) - p2)
   elif x.node_type == nd_While:
       p1 = len(code)
       code_gen(x.left)
       emit_byte(JZ)
       p2 = hole()
       code_gen(x.right)
       emit_byte(JMP)                       # jump back to the top
       emit_word(p1 - len(code))
       emit_word_at(p2, len(code) - p2)
   elif x.node_type == nd_Sequence:
       code_gen(x.left)
       code_gen(x.right)
   elif x.node_type == nd_Prtc:
       code_gen(x.left)
       emit_byte(PRTC)
   elif x.node_type == nd_Prti:
       code_gen(x.left)
       emit_byte(PRTI)
   elif x.node_type == nd_Prts:
       code_gen(x.left)
       emit_byte(PRTS)
   elif x.node_type in operators:
       code_gen(x.left)
       code_gen(x.right)
       emit_byte(operators[x.node_type])
   elif x.node_type in unary_operators:
       code_gen(x.left)
       emit_byte(unary_operators[x.node_type])
   else:
       error("error in code generator - found %d, expecting operator" % (x.node_type))

def code_finish(): 

   emit_byte(HALT)

def list_code(): 

   print("Datasize: %d Strings: %d" % (len(globals), len(string_pool)))

   for k in sorted(string_pool, key=string_pool.get):
       print(k)

   pc = 0
   while pc < len(code):
       print("%4d " % (pc), end=)
       op = code[pc]
       pc += 1
       if op == FETCH:
           x = bytes_to_int(code[pc:pc+word_size])[0]
           print("fetch [%d]" % (x));
           pc += word_size
       elif op == STORE:
           x = bytes_to_int(code[pc:pc+word_size])[0]
           print("store [%d]" % (x));
           pc += word_size
       elif op == PUSH:
           x = bytes_to_int(code[pc:pc+word_size])[0]
           print("push  %d" % (x));
           pc += word_size
       elif op == ADD:   print("add")
       elif op == SUB:   print("sub")
       elif op == MUL:   print("mul")
       elif op == DIV:   print("div")
       elif op == MOD:   print("mod")
       elif op == LT:    print("lt")
       elif op == GT:    print("gt")
       elif op == LE:    print("le")
       elif op == GE:    print("ge")
       elif op == EQ:    print("eq")
       elif op == NE:    print("ne")
       elif op == AND:   print("and")
       elif op == OR:    print("or")
       elif op == NEG:   print("neg")
       elif op == NOT:   print("not")
       elif op == JMP:
           x = bytes_to_int(code[pc:pc+word_size])[0]
           print("jmp    (%d) %d" % (x, pc + x));
           pc += word_size
       elif op == JZ:
           x = bytes_to_int(code[pc:pc+word_size])[0]
           print("jz     (%d) %d" % (x, pc + x));
           pc += word_size
       elif op == PRTC:  print("prtc")
       elif op == PRTI:  print("prti")
       elif op == PRTS:  print("prts")
       elif op == HALT:  print("halt")
       else: error("list_code: Unknown opcode %d", (op));

def load_ast(): 

   line = input_file.readline()
   line_list = shlex.split(line, False, False)

   text = line_list[0]
   if text == ";":
       return None
   node_type = all_syms[text]

   if len(line_list) > 1:
       value = line_list[1]
       if value.isdigit():
           value = int(value)
       return make_leaf(node_type, value)

   left = load_ast()
   right = load_ast()
   return make_node(node_type, left, right)
        • main driver

input_file = sys.stdin if len(sys.argv) > 1: 

   try:
       input_file = open(sys.argv[1], "r", 4096)
   except IOError as e:
       error("Can't open %s" % sys.argv[1])

n = load_ast() code_gen(n) code_finish() list_code()</lang>

Output  —  While counter example:

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

Raku

(formerly Perl 6) Using 'while-count' example, input used is here: ast.txt

Translation of: Perl

<lang perl6>my %opnames = < 

   Less   lt     LessEqual    le     Multiply mul    Subtract sub    NotEqual ne
   Divide div    GreaterEqual ge     Equal    eq     Greater  gt     Negate   neg

>;

my (@AST, %strings, %names); my $string-count = my $name-count = my $pairsym = my $pc = 0;

sub tree { 

   my ($A, $B) = ( '_' ~ ++$pairsym, '_' ~ ++$pairsym );
   my $line = @AST.shift // return ;
   $line ~~ /^ $<instr> = (\w+|';') [\s+ $<arg> =(.*)]? / or die "bad input $line";
   given $<instr> {
       when 'Identifier' { "fetch [{%names{$<arg>} //= $name-count++ }]\n" }
       when 'Sequence'   { tree() ~ tree() }
       when 'Integer'    { "push  $<arg>\n" }
       when 'String'     { "push  { %strings{$<arg>} //= $string-count++ }\n" }
       when 'Assign'     { join , reverse (tree().subst( /fetch/, 'store')), tree() }
       when 'While'      { "$A:\n{ tree() }jz    $B\n{ tree() }jmp   $A\n$B:\n" }
       when 'If'         { tree() ~ "jz    $A\n{ !@AST.shift ~ tree() }jmp   $B\n$A:\n{ tree() }$B:\n" }
       when ';'          {  }
       default           { tree() ~ tree() ~ (%opnames{$<instr>} // $<instr>.lc) ~ "\n" }
   }

}

@AST = slurp('ast.txt').lines; my $code = tree() ~ "halt\n";

$code ~~ s:g/^^ jmp \s+ (\S+) \n ('_'\d+:\n) $0:\n/$1/; # remove jmp next $code ~~ s:g/^^ (<[a..z]>\w* (\N+)? ) $$/{my $l=$pc.fmt("%4d "); $pc += $0[0] ?? 5 !! 1; $l}$0/; # add locations my %labels = ($code ~~ m:g/^^ ('_' \d+) ':' \n \s* (\d+)/)».Slip».Str; # pc addr of labels $code ~~ s:g/^^ \s* (\d+) \s j[z|mp] \s* <(('_'\d+)/ ({%labels{$1} - $0 - 1}) %labels{$1}/; # fix jumps $code ~~ s:g/^^ '_'\d+.*?\n//; # remove labels

say "Datasize: $name-count Strings: $string-count\n" 

  ~ join(, %strings.keys.sort.reverse «~» "\n")
  ~ $code;</lang>
Output:
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

RATFOR

Works with: ratfor77 version public domain 1.0
Works with: gfortran version 11.3.0
Works with: f2c version 20100827


<lang ratfor>######################################################################

  2. The Rosetta Code code generator in Ratfor 77.
  5. In FORTRAN 77 and therefore in Ratfor 77, there is no way to specify
  6. that a value should be put on a call stack. Therefore there is no
  7. way to implement recursive algorithms in Ratfor 77 (although see the
  8. Ratfor for the "syntax analyzer" task, where a recursive language is
  9. implemented *in* Ratfor). We are forced to use non-recursive
  10. algorithms.
  12. How to deal with FORTRAN 77 input is another problem. I use
  13. formatted input, treating each line as an array of type
  14. CHARACTER--regrettably of no more than some predetermined, finite
  15. length. It is a very simple method and presents no significant
  16. difficulties, aside from the restriction on line length of the
  17. input.
  20. On a POSIX platform, the program can be compiled with f2c and run
  21. somewhat as follows:
  23. ratfor77 gen-in-ratfor.r > gen-in-ratfor.f
  24. f2c -C -Nc80 gen-in-ratfor.f
  25. cc gen-in-ratfor.c -lf2c
  26. ./a.out < compiler-tests/primes.ast
  28. With gfortran, a little differently:
  30. ratfor77 gen-in-ratfor.r > gen-in-ratfor.f
  31. gfortran -fcheck=all -std=legacy gen-in-ratfor.f
  32. ./a.out < compiler-tests/primes.ast
  35. I/O is strictly from default input and to default output, which, on
  36. POSIX systems, usually correspond respectively to standard input and
  37. standard output. (I did not wish to have to deal with unit numbers;
  38. these are now standardized in ISO_FORTRAN_ENV, but that is not
  39. available in FORTRAN 77.)
  41. ---------------------------------------------------------------------
  1. 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.

  1. ---------------------------------------------------------------------

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

  1. ---------------------------------------------------------------------

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)

  1. 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)

  1. ---------------------------------------------------------------------

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

  1. ---------------------------------------------------------------------

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

  1. ---------------------------------------------------------------------

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

  1. ---------------------------------------------------------------------

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

  1. ---------------------------------------------------------------------

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

  1. ---------------------------------------------------------------------

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

  1. ---------------------------------------------------------------------

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

                                                                                                                                            1. </lang>
Output:
$ ratfor77 gen-in-ratfor.r > gen-in-ratfor.f && gfortran -fcheck=all -std=legacy -O2 gen-in-ratfor.f && ./a.out < compiler-tests/primes.ast
Datasize: 5 Strings: 3
" is prime\n"
"Total primes found: "
"\n"
         0  push    1
         5  store   [0]
        10  push    1
        15  store   [1]
        20  push    100
        25  store   [2]
        30  fetch   [1]
        35  fetch   [2]
        40  lt
        41  jz      (160) 202
        46  push    3
        51  store   [3]
        56  push    1
        61  store   [4]
        66  fetch   [1]
        71  push    2
        76  add
        77  store   [1]
        82  fetch   [3]
        87  fetch   [3]
        92  mul
        93  fetch   [1]
        98  le
        99  fetch   [4]
       104  and
       105  jz      (53) 159
       110  fetch   [1]
       115  fetch   [3]
       120  div
       121  fetch   [3]
       126  mul
       127  fetch   [1]
       132  ne
       133  store   [4]
       138  fetch   [3]
       143  push    2
       148  add
       149  store   [3]
       154  jmp     (-73) 82
       159  fetch   [4]
       164  jz      (32) 197
       169  fetch   [1]
       174  prti
       175  push    0
       180  prts
       181  fetch   [0]
       186  push    1
       191  add
       192  store   [0]
       197  jmp     (-168) 30
       202  push    1
       207  prts
       208  fetch   [0]
       213  prti
       214  push    2
       219  prts
       220  halt


Scala

The complete implementation for the compiler tasks can be found in a GitHub repository at github.com/edadma/rosettacodeCompiler which includes full unit testing for the samples given in Compiler/Sample programs.

The following code implements a code generator for the output of the parser.

<lang scala> package xyz.hyperreal.rosettacodeCompiler

import scala.collection.mutable.{ArrayBuffer, HashMap} import scala.io.Source

object CodeGenerator { 

 def fromStdin = fromSource(Source.stdin)

 def fromString(src: String) = fromSource(Source.fromString(src))

 def fromSource(ast: Source) = {
   val vars              = new HashMap[String, Int]
   val strings           = new ArrayBuffer[String]
   val code              = new ArrayBuffer[String]
   var s: Stream[String] = ast.getLines.toStream

   def line =
     if (s.nonEmpty) {
       val n = s.head

       s = s.tail

       n.split(" +", 2) match {
         case Array(n) => n
         case a        => a
       }
     } else
       sys.error("unexpected end of AST")

   def variableIndex(name: String) =
     vars get name match {
       case None =>
         val idx = vars.size

         vars(name) = idx
         idx
       case Some(idx) => idx
     }

   def stringIndex(s: String) =
     strings indexOf s match {
       case -1 =>
         val idx = strings.length

         strings += s
         idx
       case idx => idx
     }

   var loc = 0

   def addSimple(inst: String) = {
     code += f"$loc%4d $inst"
     loc += 1
   }

   def addOperand(inst: String, operand: String) = {
     code += f"$loc%4d $inst%-5s $operand"
     loc += 5
   }

   def fixup(inst: String, idx: Int, at: Int) = code(idx) = f"$at%4d $inst%-5s (${loc - at - 1}) $loc"

   generate
   addSimple("halt")
   println(s"Datasize: ${vars.size} Strings: ${strings.length}")

   for (s <- strings)
     println(s)

   println(code mkString "\n")

   def generate: Unit =
     line match {
       case "Sequence" =>
         generate
         generate
       case ";" =>
       case "Assign" =>
         val idx =
           line match {
             case Array("Identifier", name: String) =>
               variableIndex(name)
             case l => sys.error(s"expected identifier: $l")
           }

         generate
         addOperand("store", s"[$idx]")
       case Array("Identifier", name: String) => addOperand("fetch", s"[${variableIndex(name)}]")
       case Array("Integer", n: String)       => addOperand("push", s"$n")
       case Array("String", s: String)        => addOperand("push", s"${stringIndex(s)}")
       case "If" =>
         generate

         val cond    = loc
         val condidx = code.length

         addOperand("", "")
         s = s.tail
         generate

         if (s.head == ";") {
           s = s.tail
           fixup("jz", condidx, cond)
         } else {
           val jump    = loc
           val jumpidx = code.length

           addOperand("", "")
           fixup("jz", condidx, cond)
           generate
           fixup("jmp", jumpidx, jump)
         }
       case "While" =>
         val start = loc

         generate

         val cond    = loc
         val condidx = code.length

         addOperand("", "")
         generate
         addOperand("jmp", s"(${start - loc - 1}) $start")
         fixup("jz", condidx, cond)
       case op =>
         generate
         generate
         addSimple(
           op match {
             case "Prti"         => "prti"
             case "Prts"         => "prts"
             case "Prtc"         => "prtc"
             case "Add"          => "add"
             case "Subtract"     => "sub"
             case "Multiply"     => "mul"
             case "Divide"       => "div"
             case "Mod"          => "mod"
             case "Less"         => "lt"
             case "LessEqual"    => "le"
             case "Greater"      => "gt"
             case "GreaterEqual" => "ge"
             case "Equal"        => "eq"
             case "NotEqual"     => "ne"
             case "And"          => "and"
             case "Or"           => "or"
             case "Negate"       => "neg"
             case "Not"          => "not"
           }
         )
     }
 }

} </lang>

Scheme

<lang scheme> (import (scheme base) 

       (scheme file)
       (scheme process-context)
       (scheme write)
       (only (srfi 1) delete-duplicates list-index)
       (only (srfi 13) string-delete string-index string-trim))

(define *names* '((Add add) (Subtract sub) (Multiply mul) (Divide div) (Mod mod) 

                           (Less lt) (Greater gt) (LessEqual le) (GreaterEqual ge) 
                           (Equal eq) (NotEqual ne) (And and) (Or or) (Negate neg) 
                           (Not not) (Prts prts) (Prti prti) (Prtc prtc)))

(define (change-name name) 

 (if (assq name *names*)
   (cdr (assq name *names*))
   (error "Cannot find name" name)))
Read AST from given filename
- return as an s-expression

(define (read-code filename) 

 (define (read-expr)
   (let ((line (string-trim (read-line))))
     (if (string=? line ";")
       '()
       (let ((space (string-index line #\space)))
         (if space
           (list (string->symbol (string-trim (substring line 0 space)))
                 (string-trim (substring line space (string-length line))))
           (list (string->symbol line) (read-expr) (read-expr)))))))
 ;
 (with-input-from-file filename (lambda () (read-expr))))
run a three-pass assembler

(define (generate-code ast) 

 (define new-address ; create a new unique address - for jump locations
   (let ((count 0))
     (lambda ()
       (set! count (+ 1 count))
       (string->symbol (string-append "loc-" (number->string count))))))
 ; define some names for fields
 (define left cadr)
 (define right (lambda (x) (cadr (cdr x))))
 ;
 (define (extract-values ast)
   (if (null? ast)
     (values '() '())
     (case (car ast)
       ((Integer)
        (values '() '()))
       ((Negate Not Prtc Prti Prts)
        (extract-values (left ast)))
       ((Assign Add Subtract Multiply Divide Mod Less Greater LessEqual GreaterEqual 
                Equal NotEqual And Or If While Sequence)
        (let-values (((a b) (extract-values (left ast)))
                     ((c d) (extract-values (right ast))))
                    (values (delete-duplicates (append a c) string=?)
                            (delete-duplicates (append b d) string=?))))
       ((String)
        (values '() (list (left ast))))
       ((Identifier)
        (values (list (left ast)) '())))))
 ;
 (let-values (((constants strings) (extract-values ast)))
             (define (constant-idx term)
               (list-index (lambda (s) (string=? s term)) constants))
             (define (string-idx term)
               (list-index (lambda (s) (string=? s term)) strings))
             ;
             (define (pass-1 ast asm) ; translates ast into a list of basic operations
               (if (null? ast)
                 asm
                 (case (car ast)
                   ((Integer)
                    (cons (list 'push (left ast)) asm))
                   ((Identifier)
                    (cons (list 'fetch (constant-idx (left ast))) asm))
                   ((String)
                    (cons (list 'push (string-idx (left ast))) asm))
                   ((Assign)
                    (cons (list 'store (constant-idx (left (left ast)))) (pass-1 (right ast) asm)))
                   ((Add Subtract Multiply Divide Mod Less Greater LessEqual GreaterEqual 
                         Equal NotEqual And Or) ; binary operators
                    (cons (change-name (car ast))
                          (pass-1 (right ast) (pass-1 (left ast) asm))))
                   ((Negate Not Prtc Prti Prts) ; unary operations
                    (cons (change-name (car ast))
                          (pass-1 (left ast) asm)))
                   ((If)
                    (let ((label-else (new-address))
                          (label-end (new-address)))
                      (if (null? (right (right ast)))
                        (cons (list 'label label-end) ; label for end of if statement
                              (pass-1 (left (right ast)) ; output the 'then block
                                      (cons (list 'jz label-end) ; jump to end when test is false
                                            (pass-1 (left ast) asm))))
                        (cons (list 'label label-end) ; label for end of if statement
                              (pass-1 (right (right ast)) ; output the 'else block
                                      (cons (list 'label label-else)
                                            (cons (list 'jmp label-end) ; jump past 'else, after 'then
                                                  (pass-1 (left (right ast)) ; output the 'then block
                                                          (cons (list 'jz label-else) ; jumpt to else when false
                                                                (pass-1 (left ast) asm))))))))))
                   ((While)
                    (let ((label-test (new-address))
                          (label-end (new-address)))
                      (cons (list 'label label-end) ; introduce a label for end of while block 
                            (cons (list 'jmp label-test) ; jump back to repeat test
                                  (pass-1 (right ast)  ; output the block
                                          (cons (list 'jz label-end) ; test failed, jump around block
                                                (pass-1 (left ast) ; output the test
                                                        (cons (list 'label label-test) ; introduce a label for test
                                                              asm))))))))
                   ((Sequence)
                    (pass-1 (right ast) (pass-1 (left ast) asm)))
                   (else
                     "Unknown token type"))))
             ;
             (define (pass-2 asm) ; adds addresses and fills in jump locations
               (define (fill-addresses)
                 (let ((addr 0))
                   (map (lambda (instr)
                          (let ((res (cons addr instr)))
                            (unless (eq? (car instr) 'label)
                              (set! addr (+ addr (if (= 1 (length instr)) 1 5))))
                            res))
                        asm)))
               ; 
               (define (extract-labels asm)
                 (let ((labels '()))
                   (for-each (lambda (instr) 
                               (when (eq? (cadr instr) 'label)
                                 (set! labels (cons (cons (cadr (cdr instr)) (car instr))
                                                    labels))))
                             asm)
                   labels))
               ;
               (define (add-jump-locations asm labels rec)
                 (cond ((null? asm)
                        (reverse rec))
                       ((eq? (cadr (car asm)) 'label) ; ignore the labels
                        (add-jump-locations (cdr asm) labels rec))
                       ((memq (cadr (car asm)) '(jmp jz)) ; replace labels with addresses for jumps
                        (add-jump-locations (cdr asm)
                                            labels
                                            (cons (list (car (car asm)) ; previous address
                                                        (cadr (car asm)) ; previous jump type
                                                        (cdr (assq (cadr (cdar asm)) labels))) ; actual address
                                                  rec)))
                       (else
                         (add-jump-locations (cdr asm) labels (cons (car asm) rec)))))
               ;
               (let ((asm+addr (fill-addresses)))
                 (add-jump-locations asm+addr (extract-labels asm+addr) '())))
             ;
             (define (output-instruction instr)
                  (display (number->string (car instr))) (display #\tab) 
                  (display (cadr instr)) (display #\tab)
               (case (cadr instr)
                 ((fetch store)
                  (display "[") (display (number->string (cadr (cdr instr)))) (display "]\n"))
                 ((jmp jz)
                  (display 
                    (string-append "("
                                   (number->string (- (cadr (cdr instr)) (car instr) 1))
                                   ")")) 
                  (display #\tab)
                  (display (number->string (cadr (cdr instr)))) (newline))
                 ((push)
                  (display (cadr (cdr instr))) (newline))
                 (else
                   (newline))))
             ; generate the code and output to stdout
             (display 
               (string-append "Datasize: "
                              (number->string (length constants)) 
                              " Strings: "
                              (number->string (length strings))))
             (newline)
             (for-each (lambda (str) (display str) (newline))
                       strings)
             (for-each output-instruction
                       (pass-2 (reverse (cons (list 'halt) (pass-1 ast '())))))))
read AST from file and output code to stdout

(if (= 2 (length (command-line))) 

 (generate-code (read-code (cadr (command-line))))
 (display "Error: pass an ast filename\n"))

</lang>

Tested on all examples in Compiler/Sample programs.

Wren

Translation of: Go
Library: Wren-dynamic
Library: Wren-crypto
Library: Wren-fmt
Library: Wren-ioutil

<lang ecmascript>import "/dynamic" for Enum, Struct, Tuple import "/crypto" for Bytes import "/fmt" for Fmt import "/ioutil" for FileUtil

var nodes = [ 

   "Ident",
   "String",
   "Integer",
   "Sequence",
   "If",
   "Prtc",
   "Prts",
   "Prti",
   "While",
   "Assign",
   "Negate",
   "Not",
   "Mul",
   "Div",
   "Mod",
   "Add",
   "Sub",
   "Lss",
   "Leq",
   "Gtr",
   "Geq",
   "Eql",
   "Neq",
   "And",
   "Or"

]

var Node = Enum.create("Node", nodes)

var codes = [ 

   "fetch",
   "store",
   "push",
   "add",
   "sub",
   "mul",
   "div",
   "mod",
   "lt",
   "gt",
   "le",
   "ge",
   "eq",
   "ne",
   "and",
   "or",
   "neg",
   "not",
   "jmp",
   "jz",
   "prtc",
   "prts",
   "prti",
   "halt"

]

var Code = Enum.create("Code", codes)

var Tree = Struct.create("Tree", ["nodeType", "left", "right", "value"])

// dependency: Ordered by Node value, must remain in same order as Node enum var Atr = Tuple.create("Atr", ["enumText", "nodeType", "opcode"])

var atrs = [ 

   Atr.new("Identifier", Node.Ident, 255),
   Atr.new("String", Node.String, 255),
   Atr.new("Integer", Node.Integer, 255),
   Atr.new("Sequence", Node.Sequence, 255),
   Atr.new("If", Node.If, 255),
   Atr.new("Prtc", Node.Prtc, 255),
   Atr.new("Prts", Node.Prts, 255),
   Atr.new("Prti", Node.Prti, 255),
   Atr.new("While", Node.While, 255),
   Atr.new("Assign", Node.Assign, 255),
   Atr.new("Negate", Node.Negate, Code.neg),
   Atr.new("Not", Node.Not, Code.not),
   Atr.new("Multiply", Node.Mul, Code.mul),
   Atr.new("Divide", Node.Div, Code.div),
   Atr.new("Mod", Node.Mod, Code.mod),
   Atr.new("Add", Node.Add, Code.add),
   Atr.new("Subtract", Node.Sub, Code.sub),
   Atr.new("Less", Node.Lss, Code.lt),
   Atr.new("LessEqual", Node.Leq, Code.le),
   Atr.new("Greater", Node.Gtr, Code.gt),
   Atr.new("GreaterEqual", Node.Geq, Code.ge),
   Atr.new("Equal", Node.Eql, Code.eq),
   Atr.new("NotEqual", Node.Neq, Code.ne),
   Atr.new("And", Node.And, Code.and),
   Atr.new("Or", Node.Or, Code.or),

]

var stringPool = [] var globals = [] var object = []

var reportError = Fn.new { |msg| Fiber.abort("error : %(msg)") }

var nodeToOp = Fn.new { |nodeType| atrs[nodeType].opcode }

var makeNode = Fn.new { |nodeType, left, right| Tree.new(nodeType, left, right, "") }

var makeLeaf = Fn.new { |nodeType, value| Tree.new(nodeType, null, null, value) }

/* Code generator */

var emitByte = Fn.new { |c| object.add(c) }

var emitWord = Fn.new { |n| 

   var bs = Bytes.fromIntLE(n)
   for (b in bs) emitByte.call(b)

}

var emitWordAt = Fn.new { |at, n| 

   var bs = Bytes.fromIntLE(n)
   for (i in at...at+4) object[i] = bs[i-at]

}

var hole = Fn.new { 

   var t = object.count
   emitWord.call(0)
   return t

}

var fetchVarOffset = Fn.new { |id| 

   for (i in 0...globals.count) {
       if (globals[i] == id) return i
   }
   globals.add(id)
   return globals.count - 1

}

var fetchStringOffset = Fn.new { |st| 

   for (i in 0...stringPool.count) {
       if (stringPool[i] == st) return i
   }
   stringPool.add(st)
   return stringPool.count - 1

}

var binOpNodes = [ 

   Node.Lss, Node.Gtr, Node.Leq, Node.Geq, Node.Eql, Node.Neq,
   Node.And, Node.Or, Node.Sub, Node.Add, Node.Div, Node.Mul, Node.Mod

]

var codeGen // recursive function codeGen = Fn.new { |x| 

   if (!x) return 
   var n
   var p1
   var p2
   var nt = x.nodeType 
   if (nt == Node.Ident) {
       emitByte.call(Code.fetch)
       n = fetchVarOffset.call(x.value)
       emitWord.call(n)
   } else if (nt == Node.Integer) {
       emitByte.call(Code.push)
       n = Num.fromString(x.value)
       emitWord.call(n)
   } else if (nt == Node.String) {
       emitByte.call(Code.push)
       n = fetchStringOffset.call(x.value)
       emitWord.call(n)
   } else if (nt == Node.Assign) {
       n = fetchVarOffset.call(x.left.value)
       codeGen.call(x.right)
       emitByte.call(Code.store)
       emitWord.call(n)
   } else if (nt == Node.If) {
       codeGen.call(x.left)       // if expr
       emitByte.call(Code.jz)     // if false, jump
       p1 = hole.call()           // make room forjump dest
       codeGen.call(x.right.left) // if true statements
       if (x.right.right) {
           emitByte.call(Code.jmp)
           p2 = hole.call()
       }
       emitWordAt.call(p1, object.count-p1)
       if (x.right.right) {
           codeGen.call(x.right.right)
           emitWordAt.call(p2, object.count-p2)
       }
   } else if (nt == Node.While) {
       p1 = object.count
       codeGen.call(x.left)                 // while expr
       emitByte.call(Code.jz)               // if false, jump
       p2 = hole.call()                     // make room for jump dest
       codeGen.call(x.right)                // statements
       emitByte.call(Code.jmp)              // back to the top
       emitWord.call(p1 - object.count)     // plug the top
       emitWordAt.call(p2, object.count-p2) // plug the 'if false, jump'
   } else if (nt == Node.Sequence) {
       codeGen.call(x.left)
       codeGen.call(x.right)
   } else if (nt == Node.Prtc) {
       codeGen.call(x.left)
       emitByte.call(Code.prtc)
   } else if (nt == Node.Prti) {
       codeGen.call(x.left)
       emitByte.call(Code.prti)
   } else if (nt == Node.Prts) {
       codeGen.call(x.left)
       emitByte.call(Code.prts)
   } else if (binOpNodes.contains(nt)) {
       codeGen.call(x.left)
       codeGen.call(x.right)
       emitByte.call(nodeToOp.call(x.nodeType))
   } else if (nt == Node.negate || nt == Node.Not) {
       codeGen.call(x.left)
       emitByte.call(nodeToOp.call(x.nodeType))
   } else {
       var msg = "error in code generator - found %(x.nodeType) expecting operator"
       reportError.call(msg)
   }

}

// Converts the 4 bytes starting at object[pc] to an unsigned 32 bit integer // and thence to a signed 32 bit integer var toInt32LE = Fn.new { |pc| 

   var x = Bytes.toIntLE(object[pc...pc+4])
   if (x >= 2.pow(31)) x = x - 2.pow(32)
   return x

}

var codeFinish = Fn.new { emitByte.call(Code.halt) }

var listCode = Fn.new { 

   Fmt.print("Datasize: $d Strings: $d", globals.count, stringPool.count)
   for (s in stringPool) System.print(s)
   var pc = 0
   while (pc < object.count) {
       Fmt.write("$5d ", pc)
       var op = object[pc]
       pc = pc + 1
       if (op == Code.fetch) {
           var x = toInt32LE.call(pc)
           Fmt.print("fetch [$d]", x)
           pc = pc + 4
       } else if (op == Code.store) {
           var x = toInt32LE.call(pc)
           Fmt.print("store [$d]", x)
           pc = pc + 4
       } else if (op == Code.push) {
           var x = toInt32LE.call(pc)
           Fmt.print("push  $d", x)
           pc = pc + 4
       } else if (op == Code.add) {
           System.print("add")
       } else if (op == Code.sub) {
           System.print("sub")
       } else if (op == Code.mul) {
           System.print("mul")
       } else if (op == Code.div) {
           System.print("div")
       } else if (op == Code.mod) {
           System.print("mod")
       } else if (op == Code.lt) {
           System.print("lt")
       } else if (op == Code.gt) {
           System.print("gt")
       } else if (op == Code.le) {
           System.print("le")
       } else if (op == Code.ge) {
           System.print("ge")
       } else if (op == Code.eq) {
           System.print("eq")
       } else if (op == Code.ne) {
           System.print("ne")
       } else if (op == Code.and) {
           System.print("and")
       } else if (op == Code.or) {
           System.print("or")
       } else if (op == Code.neg) {
           System.print("neg")
       } else if (op == Code.not) {
           System.print("not")
       } else if (op == Code.jmp) {
           var x = toInt32LE.call(pc)
           Fmt.print("jmp    ($d) $d", x, pc+x)
           pc = pc + 4
       } else if (op == Code.jz) {
           var x = toInt32LE.call(pc)
           Fmt.print("jz     ($d) $d", x, pc+x)
           pc = pc + 4
       } else if (op == Code.prtc) {
           System.print("prtc")
       } else if (op == Code.prti){
           System.print("prti")
       } else if (op == Code.prts) {
           System.print("prts")
       } else if (op == Code.halt) {
           System.print("halt")
       } else {
           reportError.call("listCode: Unknown opcode %(op)")
       }
   }

}

var getEnumValue = Fn.new { |name| 

   for (atr in atrs) {
       if (atr.enumText == name) return atr.nodeType
   }
   reportError.call("Unknown token %(name)")

}

var lines = [] var lineCount = 0 var lineNum = 0

var loadAst // recursive function loadAst = Fn.new { 

   var nodeType = 0
   var s = ""
   if (lineNum < lineCount) {
       var line = lines[lineNum].trimEnd(" \t")
       lineNum = lineNum + 1
       var tokens = line.split(" ").where { |s| s != "" }.toList
       var first = tokens[0]
       if (first[0] == ";") return null
       nodeType = getEnumValue.call(first)
       var le = tokens.count
       if (le == 2) {
           s = tokens[1]
       } else if (le > 2) {
           var idx = line.indexOf("\"")
           s = line[idx..-1]
       }
   }
   if (s != "") return makeLeaf.call(nodeType, s)
   var left  = loadAst.call()
   var right = loadAst.call()
   return makeNode.call(nodeType, left, right)

}

lines = FileUtil.readLines("ast.txt") lineCount = lines.count codeGen.call(loadAst.call()) codeFinish.call() listCode.call()</lang>

Output:
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

Zig

<lang zig> const std = @import("std");

pub const CodeGeneratorError = error{OutOfMemory};

pub const CodeGenerator = struct { 

   allocator: std.mem.Allocator,
   string_pool: std.ArrayList([]const u8),
   globals: std.ArrayList([]const u8),
   bytecode: std.ArrayList(u8),

   const Self = @This();
   const word_size = @sizeOf(i32);

   pub fn init(
       allocator: std.mem.Allocator,
       string_pool: std.ArrayList([]const u8),
       globals: std.ArrayList([]const u8),
   ) Self {
       return CodeGenerator{
           .allocator = allocator,
           .string_pool = string_pool,
           .globals = globals,
           .bytecode = std.ArrayList(u8).init(allocator),
       };
   }

   pub fn gen(self: *Self, ast: ?*Tree) CodeGeneratorError!void {
       try self.genH(ast);
       try self.emitHalt();
   }

   // Helper function to allow recursion.
   pub fn genH(self: *Self, ast: ?*Tree) CodeGeneratorError!void {
       if (ast) |t| {
           switch (t.typ) {
               .sequence => {
                   try self.genH(t.left);
                   try self.genH(t.right);
               },
               .kw_while => {
                   const condition_address = self.currentAddress();
                   try self.genH(t.left);
                   try self.emitByte(.jz);
                   const condition_address_hole = self.currentAddress();
                   try self.emitHole();
                   try self.genH(t.right);
                   try self.emitByte(.jmp);
                   try self.emitInt(condition_address);
                   self.insertInt(condition_address_hole, self.currentAddress());
               },
               .kw_if => {
                   try self.genH(t.left);
                   try self.emitByte(.jz);
                   const condition_address_hole = self.currentAddress();
                   try self.emitHole();
                   try self.genH(t.right.?.left);
                   if (t.right.?.right) |else_tree| {
                       try self.emitByte(.jmp);
                       const else_address_hole = self.currentAddress();
                       try self.emitHole();
                       const else_address = self.currentAddress();
                       try self.genH(else_tree);
                       self.insertInt(condition_address_hole, else_address);
                       self.insertInt(else_address_hole, self.currentAddress());
                   } else {
                       self.insertInt(condition_address_hole, self.currentAddress());
                   }
               },
               .assign => {
                   try self.genH(t.right);
                   try self.emitByte(.store);
                   try self.emitInt(self.fetchGlobalsOffset(t.left.?.value.?.string));
               },
               .prts => {
                   try self.genH(t.left);
                   try self.emitByte(.prts);
               },
               .prti => {
                   try self.genH(t.left);
                   try self.emitByte(.prti);
               },
               .prtc => {
                   try self.genH(t.left);
                   try self.emitByte(.prtc);
               },
               .string => {
                   try self.emitByte(.push);
                   try self.emitInt(self.fetchStringsOffset(t.value.?.string));
               },
               .integer => {
                   try self.emitByte(.push);
                   try self.emitInt(t.value.?.integer);
               },
               .identifier => {
                   try self.emitByte(.fetch);
                   try self.emitInt(self.fetchGlobalsOffset(t.value.?.string));
               },
               .negate, .not => {
                   try self.genH(t.left);
                   try self.emitByte(Op.fromNodeType(t.typ).?);
               },
               .add,
               .multiply,
               .subtract,
               .divide,
               .mod,
               .less,
               .less_equal,
               .greater,
               .greater_equal,
               .equal,
               .not_equal,
               .bool_and,
               .bool_or,
               => try self.genBinOp(t),
               .unknown => {
                   std.debug.print("\nINTERP: UNKNOWN {}\n", .{t.typ});
                   std.os.exit(1);
               },
           }
       }
   }

   fn genBinOp(self: *Self, tree: *Tree) CodeGeneratorError!void {
       try self.genH(tree.left);
       try self.genH(tree.right);
       try self.emitByte(Op.fromNodeType(tree.typ).?);
   }

   fn emitByte(self: *Self, op: Op) CodeGeneratorError!void {
       try self.bytecode.append(@enumToInt(op));
   }

   fn emitInt(self: *Self, n: i32) CodeGeneratorError!void {
       var n_var = n;
       var n_bytes = @ptrCast(*[4]u8, &n_var);
       for (n_bytes) |byte| {
           try self.bytecode.append(byte);
       }
   }

   // Holes are later populated via `insertInt` because they can't be known when
   // we populate the bytecode array sequentially.
   fn emitHole(self: *Self) CodeGeneratorError!void {
       try self.emitInt(std.math.maxInt(i32));
   }

   // Populates the "hole" produced by `emitHole`.
   fn insertInt(self: *Self, address: i32, n: i32) void {
       var i: i32 = 0;
       var n_var = n;
       var n_bytes = @ptrCast(*[4]u8, &n_var);
       while (i < word_size) : (i += 1) {
           self.bytecode.items[@intCast(usize, address + i)] = n_bytes[@intCast(usize, i)];
       }
   }

   fn emitHalt(self: *Self) CodeGeneratorError!void {
       try self.bytecode.append(@enumToInt(Op.halt));
   }

   fn currentAddress(self: Self) i32 {
       return @intCast(i32, self.bytecode.items.len);
   }

   fn fetchStringsOffset(self: Self, str: []const u8) i32 {
       for (self.string_pool.items) |string, idx| {
           if (std.mem.eql(u8, string, str)) {
               return @intCast(i32, idx);
           }
       }
       unreachable;
   }

   fn fetchGlobalsOffset(self: Self, str: []const u8) i32 {
       for (self.globals.items) |global, idx| {
           if (std.mem.eql(u8, global, str)) {
               return @intCast(i32, idx);
           }
       }
       unreachable;
   }

   pub fn print(self: Self) ![]u8 {
       var result = std.ArrayList(u8).init(self.allocator);
       var writer = result.writer();
       try writer.print(
           "Datasize: {d} Strings: {d}\n",
           .{ self.globals.items.len, self.string_pool.items.len },
       );
       for (self.string_pool.items) |string| {
           try writer.print("{s}\n", .{string});
       }

       var pc: usize = 0;
       while (pc < self.bytecode.items.len) : (pc += 1) {
           try writer.print("{d:>5} ", .{pc});
           switch (@intToEnum(Op, self.bytecode.items[pc])) {
               .push => {
                   try writer.print("push  {d}\n", .{self.unpackInt(pc + 1)});
                   pc += word_size;
               },
               .store => {
                   try writer.print("store [{d}]\n", .{self.unpackInt(pc + 1)});
                   pc += word_size;
               },
               .fetch => {
                   try writer.print("fetch [{d}]\n", .{self.unpackInt(pc + 1)});
                   pc += word_size;
               },
               .jz => {
                   const address = self.unpackInt(pc + 1);
                   try writer.print("jz     ({d}) {d}\n", .{ address - @intCast(i32, pc) - 1, address });
                   pc += word_size;
               },
               .jmp => {
                   const address = self.unpackInt(pc + 1);
                   try writer.print("jmp    ({d}) {d}\n", .{ address - @intCast(i32, pc) - 1, address });
                   pc += word_size;
               },
               else => try writer.print("{s}\n", .{Op.toString(@intToEnum(Op, self.bytecode.items[pc]))}),
           }
       }

       return result.items;
   }

   fn unpackInt(self: Self, pc: usize) i32 {
       const arg_ptr = @ptrCast(*[4]u8, self.bytecode.items[pc .. pc + word_size]);
       var arg_array = arg_ptr.*;
       const arg = @ptrCast(*i32, @alignCast(@alignOf(i32), &arg_array));
       return arg.*;
   }

};

pub const Op = enum(u8) { 

   fetch,
   store,
   push,
   add,
   sub,
   mul,
   div,
   mod,
   lt,
   gt,
   le,
   ge,
   eq,
   ne,
   @"and",
   @"or",
   neg,
   not,
   jmp,
   jz,
   prtc,
   prts,
   prti,
   halt,

   const from_node = std.enums.directEnumArray(NodeType, ?Op, 0, .{
       .unknown = null,
       .identifier = null,
       .string = null,
       .integer = null,
       .sequence = null,
       .kw_if = null,
       .prtc = null,
       .prts = null,
       .prti = null,
       .kw_while = null,
       .assign = null,
       .negate = .neg,
       .not = .not,
       .multiply = .mul,
       .divide = .div,
       .mod = .mod,
       .add = .add,
       .subtract = .sub,
       .less = .lt,
       .less_equal = .le,
       .greater = .gt,
       .greater_equal = .ge,
       .equal = .eq,
       .not_equal = .ne,
       .bool_and = .@"and",
       .bool_or = .@"or",
   });

   pub fn fromNodeType(node_type: NodeType) ?Op {
       return from_node[@enumToInt(node_type)];
   }

   const to_string = std.enums.directEnumArray(Op, []const u8, 0, .{
       .fetch = "fetch",
       .store = "store",
       .push = "push",
       .add = "add",
       .sub = "sub",
       .mul = "mul",
       .div = "div",
       .mod = "mod",
       .lt = "lt",
       .gt = "gt",
       .le = "le",
       .ge = "ge",
       .eq = "eq",
       .ne = "ne",
       .@"and" = "and",
       .@"or" = "or",
       .neg = "neg",
       .not = "not",
       .jmp = "jmp",
       .jz = "jz",
       .prtc = "prtc",
       .prts = "prts",
       .prti = "prti",
       .halt = "halt",
   });

   pub fn toString(self: Op) []const u8 {
       return to_string[@enumToInt(self)];
   }

};

pub fn main() !void { 

   var arena = std.heap.ArenaAllocator.init(std.heap.page_allocator);
   defer arena.deinit();
   const allocator = arena.allocator();

   var arg_it = std.process.args();
   _ = try arg_it.next(allocator) orelse unreachable; // program name
   const file_name = arg_it.next(allocator);
   // We accept both files and standard input.
   var file_handle = blk: {
       if (file_name) |file_name_delimited| {
           const fname: []const u8 = try file_name_delimited;
           break :blk try std.fs.cwd().openFile(fname, .{});
       } else {
           break :blk std.io.getStdIn();
       }
   };
   defer file_handle.close();
   const input_content = try file_handle.readToEndAlloc(allocator, std.math.maxInt(usize));

   var string_pool = std.ArrayList([]const u8).init(allocator);
   var globals = std.ArrayList([]const u8).init(allocator);
   const ast = try loadAST(allocator, input_content, &string_pool, &globals);
   var code_generator = CodeGenerator.init(allocator, string_pool, globals);
   try code_generator.gen(ast);
   const result: []const u8 = try code_generator.print();
   _ = try std.io.getStdOut().write(result);

}

pub const NodeType = enum { 

   unknown,
   identifier,
   string,
   integer,
   sequence,
   kw_if,
   prtc,
   prts,
   prti,
   kw_while,
   assign,
   negate,
   not,
   multiply,
   divide,
   mod,
   add,
   subtract,
   less,
   less_equal,
   greater,
   greater_equal,
   equal,
   not_equal,
   bool_and,
   bool_or,

   const from_string_map = std.ComptimeStringMap(NodeType, .{
       .{ "UNKNOWN", .unknown },
       .{ "Identifier", .identifier },
       .{ "String", .string },
       .{ "Integer", .integer },
       .{ "Sequence", .sequence },
       .{ "If", .kw_if },
       .{ "Prtc", .prtc },
       .{ "Prts", .prts },
       .{ "Prti", .prti },
       .{ "While", .kw_while },
       .{ "Assign", .assign },
       .{ "Negate", .negate },
       .{ "Not", .not },
       .{ "Multiply", .multiply },
       .{ "Divide", .divide },
       .{ "Mod", .mod },
       .{ "Add", .add },
       .{ "Subtract", .subtract },
       .{ "Less", .less },
       .{ "LessEqual", .less_equal },
       .{ "Greater", .greater },
       .{ "GreaterEqual", .greater_equal },
       .{ "Equal", .equal },
       .{ "NotEqual", .not_equal },
       .{ "And", .bool_and },
       .{ "Or", .bool_or },
   });

   pub fn fromString(str: []const u8) NodeType {
       return from_string_map.get(str).?;
   }

};

pub const NodeValue = union(enum) { 

   integer: i32,
   string: []const u8,

};

pub const Tree = struct { 

   left: ?*Tree,
   right: ?*Tree,
   typ: NodeType = .unknown,
   value: ?NodeValue = null,

   fn makeNode(allocator: std.mem.Allocator, typ: NodeType, left: ?*Tree, right: ?*Tree) !*Tree {
       const result = try allocator.create(Tree);
       result.* = Tree{ .left = left, .right = right, .typ = typ };
       return result;
   }

   fn makeLeaf(allocator: std.mem.Allocator, typ: NodeType, value: ?NodeValue) !*Tree {
       const result = try allocator.create(Tree);
       result.* = Tree{ .left = null, .right = null, .typ = typ, .value = value };
       return result;
   }

};

const LoadASTError = error{OutOfMemory} || std.fmt.ParseIntError;

fn loadAST( 

   allocator: std.mem.Allocator,
   str: []const u8,
   string_pool: *std.ArrayList([]const u8),
   globals: *std.ArrayList([]const u8),

) LoadASTError!?*Tree { 

   var line_it = std.mem.split(u8, str, "\n");
   return try loadASTHelper(allocator, &line_it, string_pool, globals);

}

fn loadASTHelper( 

   allocator: std.mem.Allocator,
   line_it: *std.mem.SplitIterator(u8),
   string_pool: *std.ArrayList([]const u8),
   globals: *std.ArrayList([]const u8),

) LoadASTError!?*Tree { 

   if (line_it.next()) |line| {
       var tok_it = std.mem.tokenize(u8, line, " ");
       const tok_str = tok_it.next().?;
       if (tok_str[0] == ';') return null;

       const node_type = NodeType.fromString(tok_str);
       const pre_iteration_index = tok_it.index;

       if (tok_it.next()) |leaf_value| {
           const node_value = blk: {
               switch (node_type) {
                   .integer => break :blk NodeValue{ .integer = try std.fmt.parseInt(i32, leaf_value, 10) },
                   .identifier => {
                       var already_exists = false;
                       for (globals.items) |global| {
                           if (std.mem.eql(u8, global, leaf_value)) {
                               already_exists = true;
                               break;
                           }
                       }
                       if (!already_exists) try globals.append(leaf_value);
                       break :blk NodeValue{ .string = leaf_value };
                   },
                   .string => {
                       tok_it.index = pre_iteration_index;
                       const str = tok_it.rest();
                       var already_exists = false;
                       for (string_pool.items) |string| {
                           if (std.mem.eql(u8, string, str)) {
                               already_exists = true;
                               break;
                           }
                       }
                       if (!already_exists) try string_pool.append(str);
                       break :blk NodeValue{ .string = str };
                   },
                   else => unreachable,
               }
           };
           return try Tree.makeLeaf(allocator, node_type, node_value);
       }

       const left = try loadASTHelper(allocator, line_it, string_pool, globals);
       const right = try loadASTHelper(allocator, line_it, string_pool, globals);
       return try Tree.makeNode(allocator, node_type, left, right);
   } else {
       return null;
   }

} </lang>

zkl

Translation of: Python

<lang zkl>// This is a little endian machine

const WORD_SIZE=4; const{ var _n=-1; var[proxy]N=fcn{ _n+=1 }; } // enumerator const FETCH=N, STORE=N, PUSH=N, ADD=N, SUB=N, MUL=N, DIV=N, MOD=N, 

     LT=N,    GT=N,    LE=N,   GE=N,   EQ=N,   NE=N, 
     AND=N,   OR=N,    NEG=N,  NOT=N,
     JMP=N,   JZ=N,    PRTC=N, PRTS=N, PRTI=N, HALT=N;

const nd_String=N, nd_Sequence=N, nd_If=N, nd_While=N; var all_syms=Dictionary( 

   "Identifier"  ,FETCH,       "String"      ,nd_String,
   "Integer"     ,PUSH,        "Sequence"    ,nd_Sequence,
   "If"          ,nd_If,       "Prtc"        ,PRTC,
   "Prts"        ,PRTS,        "Prti"        ,PRTI,
   "While"       ,nd_While,    "Assign"      ,STORE,
   "Negate"      ,NEG,         "Not"         ,NOT,
   "Multiply"    ,MUL,         "Divide"      ,DIV,
   "Mod"         ,MOD,         "Add"         ,ADD,
   "Subtract"    ,SUB,         "Less"        ,LT,
   "LessEqual"   ,LE,          "Greater"     ,GT,
   "GreaterEqual",GE,          "Equal"       ,EQ,
   "NotEqual"    ,NE,          "And"         ,AND,
   "Or"          ,OR,		"halt"	      ,HALT);

var binOps=T(LT,GT,LE,GE,EQ,NE, AND,OR, SUB,ADD,DIV,MUL,MOD), 

   unaryOps=T(NEG,NOT);

class Node{ 

  fcn init(_node_type, _value, _left=Void, _right=Void){
     var type=_node_type, left=_left, right=_right, value=_value;
  }

}

var vars=Dictionary(), strings=Dictionary(); // ( value:offset, ...) fcn doVar(value){ 

  var offset=-1;  // fcn local static var
  offset=_doValue(value,vars,offset)

} fcn doString(str){ str=str[1,-1]; // str is \"text\" 

  var offset=-1;  // fcn local static var
  str=str.replace("\\n","\n");
  offset=_doValue(str,strings,offset)

} fcn _doValue(value,vars,offset){ //--> offset of value in vars 

  if(Void!=(n:=vars.find(value))) return(n);	// fetch existing value
  vars[value]=offset+=1;			// store new value

}

fcn asm(node,code){ 

  if(Void==node) return(code);
  emitB:='wrap(n){ code.append(n) };
  emitW:='wrap(n){ code.append(n.toLittleEndian(WORD_SIZE)) }; // signed
  switch(node.type){
     case(FETCH)    { emitB(FETCH); emitW(doVar(node.value));    }
     case(PUSH)     { emitB(PUSH);  emitW(node.value);           }
     case(nd_String){ emitB(PUSH);  emitW(doString(node.value)); }
     case(STORE){
        asm(node.right,code);

emitB(STORE); emitW(doVar(node.left.value)); 

     }
     case(nd_If){

asm(node.left,code); # expr emitB(JZ); # if false, jump p1,p2 := code.len(),0; emitW(0); # place holder for jump dest asm(node.right.left,code); # if true statements if (node.right.right!=Void){ emitB(JMP); # jump over else statements p2=code.len(); emitW(0); } code[p1,WORD_SIZE]=(code.len() - p1).toLittleEndian(WORD_SIZE); if(node.right.right!=Void){ asm(node.right.right,code); # else statements code[p2,WORD_SIZE]=(code.len() - p2).toLittleEndian(WORD_SIZE) } 

     }
     case(nd_While){

p1:=code.len(); asm(node.left,code); emitB(JZ); p2:=code.len(); emitW(0); # place holder asm(node.right,code); emitB(JMP); # jump back to the top emitW(p1 - code.len()); code[p2,WORD_SIZE]=(code.len() - p2).toLittleEndian(WORD_SIZE); 

     }
     case(nd_Sequence){ asm(node.left,code); asm(node.right,code); }
     case(PRTC,PRTI,PRTS){ asm(node.left,code); emitB(node.type); }
     else{

if(binOps.holds(node.type)){ asm(node.left,code); asm(node.right,code); emitB(node.type); } else if(unaryOps.holds(node.type)) { asm(node.left,code); emitB(node.type); } else throw(Exception.AssertionError( "error in code generator - found %d, expecting operator" .fmt(node.type))) 

     } 
  }
  code

} fcn code_finish(code){ 

  code.append(HALT);
  // prepend the strings to the code, 
  // using my magic [66,1 byte len,text], no trailing '\0' needed
  idxs:=strings.pump(Dictionary(),"reverse");
  idxs.keys.sort().reverse().pump(Void,'wrap(n){
     text:=idxs[n];
     code.insert(0,66,text.len(),text);
  })

}</lang> <lang zkl>fcn unasm(code){ 

  all_ops,nthString := all_syms.pump(Dictionary(),"reverse"),-1;
  println("Datasize: %d bytes, Strings: %d bytes"
     .fmt(vars.len()*WORD_SIZE,strings.reduce(fcn(s,[(k,v)]){ s+k.len() },0)));
  word:='wrap(pc){ code.toLittleEndian(pc,WORD_SIZE,False) };  // signed
  pc:=0; while(pc<code.len()){
     op:=code[pc]; print("%4d: %2d ".fmt(pc,op));
     pc+=1;
     switch(op){
        case(66){

n,str := code[pc], code[pc+=1,n].text; println("String #%d %3d \"%s\"".fmt(nthString+=1,n, Compiler.Asm.quotify(str))); pc+=n; } 

        case(FETCH,STORE,PUSH){

println("%s [%d]".fmt(all_ops[op],word(pc))); pc+=WORD_SIZE; } case(ADD,SUB,MUL,DIV,MOD,LT,GT,LE,GE,EQ,NE,AND,OR,NEG,NOT, PRTC,PRTI,PRTS,HALT){ println(all_ops[op]) } 

        case(JMP){

n:=word(pc); 

           println("jmp    (%d) %d".fmt(n, pc + n));
           pc+=WORD_SIZE;

} case(JZ){ n:=word(pc); 

           println("jz     (%d) %d".fmt(n, pc + n));
           pc+=WORD_SIZE;

} else throw(Exception.AssertionError("Unknown opcode %d".fmt(op))); 

     }
  }

}</lang> <lang zkl>fcn load_ast(file){ 

  line:=file.readln().strip();		// one or two tokens
  if(line[0]==";") return(Void);
  parts,type,value := line.split(),parts[0],parts[1,*].concat(" ");
  type=all_syms[type];
  if(value){
     try{ value=value.toInt() }catch{}
     return(Node(type,value));
  } 
  left,right := load_ast(file),load_ast(file);
  Node(type,Void,left,right)

}</lang> <lang zkl>ast:=load_ast(File(vm.nthArg(0))); code:=asm(ast,Data()); code_finish(code); unasm(code); File("code.bin","wb").write(code); println("Wrote %d bytes to code.bin".fmt(code.len()));</lang> File ast.txt is the text at the start of this task.

Output:
$ zkl codeGen.zkl ast.txt 
Datasize: 4 bytes, Strings: 11 bytes
   0: 66 String #0  10 "\ncount is:"
  12: 66 String #1   1 "\n"
  15:  2 Integer [1]
  20:  1 Assign [0]
  25:  0 Identifier [0]
  30:  2 Integer [10]
  35:  8 LessEqual
  36: 19 jz     (43) 80
  41:  2 Integer [0]
  46: 21 Prts
  47:  0 Identifier [0]
  52: 22 Prti
  53:  2 Integer [1]
  58: 21 Prts
  59:  0 Identifier [0]
  64:  2 Integer [1]
  69:  3 Add
  70:  1 Assign [0]
  75: 18 jmp    (-51) 25
  80: 23 halt
Wrote 81 bytes to code.bin

$ zkl hexDump code1.bin 
   0: 42 0a 63 6f 75 6e 74 20 | 69 73 3a 20 42 01 0a 02   B.count is: B...
  16: 01 00 00 00 01 00 00 00 | 00 00 00 00 00 00 02 0a   ................
  32: 00 00 00 08 13 2b 00 00 | 00 02 00 00 00 00 15 00   .....+..........
  48: 00 00 00 00 16 02 01 00 | 00 00 15 00 00 00 00 00   ................
  64: 02 01 00 00 00 03 01 00 | 00 00 00 12 cd ff ff ff   ................
  80: 17
Retrieved from "https://rosettacode.org/wiki/Compiler/code_generator?oldid=271198"