Compiler/code generator: Difference between revisions

From Rosetta Code
Content added Content deleted
(→‎{{header|M2000 Interpreter}}: change putc to prtc)
m (→‎{{header|Wren}}: Minor tidy)
 
(32 intermediate revisions by 12 users not shown)
Line 4: Line 4:
into lower level code, either assembly, object, or virtual.
into lower level code, either assembly, object, or virtual.


=={{header|Task}}==
{{task heading}}


Take the output of the Syntax analyzer [[Compiler/syntax_analyzer|task]] - which is a [[Flatten_a_list|flattened]] Abstract Syntax Tree (AST) - and convert it to virtual machine code, that can be run by the
Take the output of the Syntax analyzer [[Compiler/syntax_analyzer|task]] - which is a [[Flatten_a_list|flattened]] Abstract Syntax Tree (AST) - and convert it to virtual machine code, that can be run by the
Line 34: Line 34:
|-
|-
| style="vertical-align:top" |
| style="vertical-align:top" |
<lang c>count = 1;
<syntaxhighlight lang="c">count = 1;
while (count < 10) {
while (count < 10) {
print("count is: ", count, "\n");
print("count is: ", count, "\n");
count = count + 1;
count = count + 1;
}</lang>
}</syntaxhighlight>


| style="vertical-align:top" |
| style="vertical-align:top" |
Line 136: Line 136:
Loading this data into an internal parse tree should be as simple as:
Loading this data into an internal parse tree should be as simple as:


<lang python>
<syntaxhighlight lang="python">
def load_ast()
def load_ast()
line = readline()
line = readline()
Line 158: Line 158:
right = load_ast()
right = load_ast()
return make_node(node_type, left, right)
return make_node(node_type, left, right)
</syntaxhighlight>
</lang>


; Output format - refer to the table above
; Output format - refer to the table above
Line 270: Line 270:
<br>
<br>
As noted in the code, the generated IL is naive - the sample focuses on simplicity.
As noted in the code, the generated IL is naive - the sample focuses on simplicity.
<lang algol68># RC Compiler code generator #
<syntaxhighlight lang="algol68"># RC Compiler code generator #
COMMENT
COMMENT
this writes a .NET IL assembler source to standard output.
this writes a .NET IL assembler source to standard output.
Line 557: Line 557:
code header;
code header;
gen( code );
gen( code );
code trailer</lang>
code trailer</syntaxhighlight>
{{out}}
{{out}}
<pre>
<pre>
Line 601: Line 601:


=={{header|ALGOL W}}==
=={{header|ALGOL W}}==
<lang algolw>begin % code generator %
<syntaxhighlight lang="algolw">begin % code generator %
% parse tree nodes %
% parse tree nodes %
record node( integer type
record node( integer type
Line 966: Line 966:
genOp0( oHalt );
genOp0( oHalt );
emitCode
emitCode
end.</lang>
end.</syntaxhighlight>
{{out}}
{{out}}
The While Counter example
The While Counter example
Line 991: Line 991:
60 jmp (-51) 10
60 jmp (-51) 10
65 halt
65 halt
</pre>

=={{header|ATS}}==
For ATS2 with a garbage collector.
<syntaxhighlight lang="ats">
(* The Rosetta Code code generator in ATS2. *)

(* Usage: gen [INPUTFILE [OUTPUTFILE]]
If INPUTFILE or OUTPUTFILE is "-" or missing, then standard input
or standard output is used, respectively. *)

(* Note: you might wish to add code to catch exceptions and print nice
messages. *)

(*------------------------------------------------------------------*)

#define ATS_DYNLOADFLAG 0

#include "share/atspre_staload.hats"
staload UN = "prelude/SATS/unsafe.sats"

#define NIL list_vt_nil ()
#define :: list_vt_cons

%{^
/* alloca(3) is needed for ATS exceptions. */
#include <alloca.h>
%}

exception internal_error of ()
exception bad_ast_node_type of string
exception premature_end_of_input of ()
exception bad_number_field of string
exception missing_identifier_field of ()
exception bad_quoted_string of string

(* Some implementations that are likely missing from the prelude. *)
implement
g0uint2int<sizeknd, llintknd> x =
$UN.cast x
implement
g0uint2uint<sizeknd, ullintknd> x =
$UN.cast x
implement
g0uint2int<ullintknd, llintknd> x =
$UN.cast x

(*------------------------------------------------------------------*)

extern fn {}
skip_characters$skipworthy (c : char) :<> bool

fn {}
skip_characters {n : int}
{i : nat | i <= n}
(s : string n,
i : size_t i)
:<> [j : int | i <= j; j <= n]
size_t j =
let
fun
loop {k : int | i <= k; k <= n}
.<n - k>.
(k : size_t k)
:<> [j : int | k <= j; j <= n]
size_t j =
if string_is_atend (s, k) then
k
else if ~skip_characters$skipworthy (string_get_at (s, k)) then
k
else
loop (succ k)
in
loop i
end

fn
skip_whitespace {n : int}
{i : nat | i <= n}
(s : string n,
i : size_t i)
:<> [j : int | i <= j; j <= n]
size_t j =
let
implement
skip_characters$skipworthy<> c =
isspace c
in
skip_characters<> (s, i)
end

fn
skip_nonwhitespace {n : int}
{i : nat | i <= n}
(s : string n,
i : size_t i)
:<> [j : int | i <= j; j <= n]
size_t j =
let
implement
skip_characters$skipworthy<> c =
~isspace c
in
skip_characters<> (s, i)
end

fn
skip_nonquote {n : int}
{i : nat | i <= n}
(s : string n,
i : size_t i)
:<> [j : int | i <= j; j <= n]
size_t j =
let
implement
skip_characters$skipworthy<> c =
c <> '"'
in
skip_characters<> (s, i)
end

fn
skip_to_end {n : int}
{i : nat | i <= n}
(s : string n,
i : size_t i)
:<> [j : int | i <= j; j <= n]
size_t j =
let
implement
skip_characters$skipworthy<> c =
true
in
skip_characters<> (s, i)
end

(*------------------------------------------------------------------*)

fn
substring_equals {n : int}
{i, j : nat | i <= j; j <= n}
(s : string n,
i : size_t i,
j : size_t j,
t : string)
:<> bool =
let
val m = strlen t
in
if j - i <> m then
false (* The substring is the wrong length. *)
else
let
val p_s = ptrcast s
and p_t = ptrcast t
in
0 = $extfcall (int, "strncmp",
ptr_add<char> (p_s, i), p_t, m)
end
end

(*------------------------------------------------------------------*)

datatype node_type_t =
| NullNode
| 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

#define ARBITRARY_NODE_ARG 1234

datatype ast_node_t =
| ast_node_t_nil
| ast_node_t_nonnil of node_contents_t
where node_contents_t =
@{
node_type = node_type_t,
node_arg = ullint,
node_left = ast_node_t,
node_right = ast_node_t
}

fn
get_node_type {n : int}
{i : nat | i <= n}
(s : string n,
i : size_t i)
: [j : int | i <= j; j <= n]
@(node_type_t,
size_t j) =
let
val i_start = skip_whitespace (s, i)
val i_end = skip_nonwhitespace (s, i_start)

macdef eq t =
substring_equals (s, i_start, i_end, ,(t))

val node_type =
if eq ";" then
NullNode
else if eq "Identifier" then
Identifier
else if eq "String" then
String
else if eq "Integer" then
Integer
else if eq "Sequence" then
Sequence
else if eq "If" then
If
else if eq "Prtc" then
Prtc
else if eq "Prts" then
Prts
else if eq "Prti" then
Prti
else if eq "While" then
While
else if eq "Assign" then
Assign
else if eq "Negate" then
Negate
else if eq "Not" then
Not
else if eq "Multiply" then
Multiply
else if eq "Divide" then
Divide
else if eq "Mod" then
Mod
else if eq "Add" then
Add
else if eq "Subtract" then
Subtract
else if eq "Less" then
Less
else if eq "LessEqual" then
LessEqual
else if eq "Greater" then
Greater
else if eq "GreaterEqual" then
GreaterEqual
else if eq "Equal" then
Equal
else if eq "NotEqual" then
NotEqual
else if eq "And" then
And
else if eq "Or" then
Or
else
let
val s_bad =
strnptr2string
(string_make_substring (s, i_start, i_end - i_start))
in
$raise bad_ast_node_type s_bad
end
in
@(node_type, i_end)
end

fn
get_unsigned {n : int}
{i : nat | i <= n}
(s : string n,
i : size_t i)
: [j : int | i <= j; j <= n]
@(ullint,
size_t j) =
let
val i = skip_whitespace (s, i)
val [j : int] j = skip_nonwhitespace (s, i)
in
if j = i then
$raise bad_number_field ""
else
let
fun
loop {k : int | i <= k; k <= j}
(k : size_t k,
v : ullint)
: ullint =
if k = j then
v
else
let
val c = string_get_at (s, k)
in
if ~isdigit c then
let
val s_bad =
strnptr2string
(string_make_substring (s, i, j - i))
in
$raise bad_number_field s_bad
end
else
let
val digit = char2int1 c - char2int1 '0'
val () = assertloc (0 <= digit)
in
loop (succ k, (g1i2u 10 * v) + g1i2u digit)
end
end
in
@(loop (i, g0i2u 0), j)
end
end

fn
get_identifier
{n : int}
{i : nat | i <= n}
(s : string n,
i : size_t i)
: [j : int | i <= j; j <= n]
@(string,
size_t j) =
let
val i = skip_whitespace (s, i)
val j = skip_nonwhitespace (s, i)
in
if i = j then
$raise missing_identifier_field ()
else
let
val ident =
strnptr2string (string_make_substring (s, i, j - i))
in
@(ident, j)
end
end

fn
get_quoted_string
{n : int}
{i : nat | i <= n}
(s : string n,
i : size_t i)
: [j : int | i <= j; j <= n]
@(string,
size_t j) =
let
val i = skip_whitespace (s, i)
in
if string_is_atend (s, i) then
$raise bad_quoted_string ""
else if string_get_at (s, i) <> '"' then
let
val j = skip_to_end (s, i)
val s_bad =
strnptr2string (string_make_substring (s, i, j - i))
in
$raise bad_quoted_string s_bad
end
else
let
val j = skip_nonquote (s, succ i)
in
if string_is_atend (s, j) then
let
val s_bad =
strnptr2string (string_make_substring (s, i, j - i))
in
$raise bad_quoted_string s_bad
end
else
let
val quoted_string =
strnptr2string
(string_make_substring (s, i, succ j - i))
in
@(quoted_string, succ j)
end
end
end

fn
collect_string
{n : int}
(str : string,
strings : &list_vt (string, n) >> list_vt (string, m))
: #[m : int | m == n || m == n + 1]
[str_num : nat | str_num <= m]
size_t str_num =
(* This implementation uses ‘list_vt’ instead of ‘list’, so
appending elements to the end of the list will be both efficient
and safe. It would also have been reasonable to build a ‘list’
backwards and then make a reversed copy. *)
let
fun
find_or_extend
{i : nat | i <= n}
.<n - i>.
(strings1 : &list_vt (string, n - i)
>> list_vt (string, m),
i : size_t i)
: #[m : int | m == n - i || m == n - i + 1]
[j : nat | j <= n]
size_t j =
case+ strings1 of
| ~ NIL =>
let (* The string is not there. Extend the list. *)
prval () = prop_verify {i == n} ()
in
strings1 := (str :: NIL);
i
end
| @ (head :: tail) =>
if head = str then
let (* The string is found. *)
prval () = fold@ strings1
in
i
end
else
let (* Continue looking. *)
val j = find_or_extend (tail, succ i)
prval () = fold@ strings1
in
j
end

prval () = lemma_list_vt_param strings
val n = i2sz (length strings)
and j = find_or_extend (strings, i2sz 0)
in
j
end

fn
load_ast (inpf : FILEref,
idents : &List_vt string >> _,
strings : &List_vt string >> _)
: ast_node_t =
let
fun
recurs (idents : &List_vt string >> _,
strings : &List_vt string >> _)
: ast_node_t =
if fileref_is_eof inpf then
$raise premature_end_of_input ()
else
let
val s = strptr2string (fileref_get_line_string inpf)
prval () = lemma_string_param s (* String length >= 0. *)

val i = i2sz 0
val @(node_type, i) = get_node_type (s, i)
in
case+ node_type of
| NullNode () => ast_node_t_nil ()
| Integer () =>
let
val @(number, _) = get_unsigned (s, i)
in
ast_node_t_nonnil
@{
node_type = node_type,
node_arg = number,
node_left = ast_node_t_nil,
node_right = ast_node_t_nil
}
end
| Identifier () =>
let
val @(ident, _) = get_identifier (s, i)
val arg = collect_string (ident, idents)
in
ast_node_t_nonnil
@{
node_type = node_type,
node_arg = g0u2u arg,
node_left = ast_node_t_nil,
node_right = ast_node_t_nil
}
end
| String () =>
let
val @(quoted_string, _) = get_quoted_string (s, i)
val arg = collect_string (quoted_string, strings)
in
ast_node_t_nonnil
@{
node_type = node_type,
node_arg = g0u2u arg,
node_left = ast_node_t_nil,
node_right = ast_node_t_nil
}
end
| _ =>
let
val node_left = recurs (idents, strings)
val node_right = recurs (idents, strings)
in
ast_node_t_nonnil
@{
node_type = node_type,
node_arg = g1i2u ARBITRARY_NODE_ARG,
node_left = node_left,
node_right = node_right
}
end
end
in
recurs (idents, strings)
end

fn
print_strings {n : int}
(outf : FILEref,
strings : !list_vt (string, n))
: void =
let
fun
loop {m : nat}
.<m>.
(strings1 : !list_vt (string, m)) :
void =
case+ strings1 of
| NIL => ()
| head :: tail =>
begin
fprintln! (outf, head);
loop tail
end

prval () = lemma_list_vt_param strings
in
loop strings
end

(*------------------------------------------------------------------*)

#define ARBITRARY_INSTRUCTION_ARG 1234
#define ARBITRARY_JUMP_ARG 123456789

typedef instruction_t =
@{
address = ullint,
opcode = string,
arg = llint
}

typedef code_t = ref instruction_t

vtypedef pjump_t (p : addr) =
(instruction_t @ p,
instruction_t @ p -<lin,prf> void |
ptr p)
vtypedef pjump_t = [p : addr] pjump_t p

fn
add_instruction (opcode : string,
arg : llint,
size : uint,
code : &List0_vt code_t >> List1_vt code_t,
pc : &ullint >> _)
: void =
let
val instr =
@{
address = pc,
opcode = opcode,
arg = arg
}
in
code := (ref instr :: code);
pc := pc + g0u2u size
end

fn
add_jump (opcode : string,
code : &List0_vt code_t >> List1_vt code_t,
pc : &ullint >> _)
: pjump_t =
let
val instr =
@{
address = pc,
opcode = opcode,
arg = g1i2i ARBITRARY_JUMP_ARG
}
val ref_instr = ref instr
in
code := (ref_instr :: code);
pc := pc + g0u2u 5U;
ref_vtakeout ref_instr
end

fn
fill_jump (pjump : pjump_t,
address : ullint)
: void =
let
val @(pf, fpf | p) = pjump
val instr0 = !p
val jump_offset : llint =
let
val from = succ (instr0.address)
and to = address
in
if from <= to then
g0u2i (to - from)
else
~g0u2i (from - to)
end
val instr1 =
@{
address = instr0.address,
opcode = instr0.opcode,
arg = jump_offset
}
val () = !p := instr1
prval () = fpf pf
in
end

fn
add_filled_jump (opcode : string,
address : ullint,
code : &List0_vt code_t >> List1_vt code_t,
pc : &ullint >> _)
: void =
let
val pjump = add_jump (opcode, code, pc)
in
fill_jump (pjump, address)
end

fn
generate_code (ast : ast_node_t)
: List_vt code_t =
let
fnx
traverse (ast : ast_node_t,
code : &List0_vt code_t >> _,
pc : &ullint >> _)
: void =
(* Generate the code by consing a list. *)
case+ ast of
| ast_node_t_nil () => ()
| ast_node_t_nonnil contents =>
begin
case+ contents.node_type of
| NullNode () => $raise internal_error ()

| If () => if_then (contents, code, pc)
| While () => while_do (contents, code, pc)

| Sequence () => sequence (contents, code, pc)
| Assign () => assign (contents, code, pc)

| Identifier () => immediate ("fetch", contents, code, pc)
| Integer () => immediate ("push", contents, code, pc)
| String () => immediate ("push", contents, code, pc)

| Prtc () => unary_op ("prtc", contents, code, pc)
| Prti () => unary_op ("prti", contents, code, pc)
| Prts () => unary_op ("prts", contents, code, pc)
| Negate () => unary_op ("neg", contents, code, pc)
| Not () => unary_op ("not", contents, code, pc)

| Multiply () => binary_op ("mul", contents, code, pc)
| Divide () => binary_op ("div", contents, code, pc)
| Mod () => binary_op ("mod", contents, code, pc)
| Add () => binary_op ("add", contents, code, pc)
| Subtract () => binary_op ("sub", contents, code, pc)
| Less () => binary_op ("lt", contents, code, pc)
| LessEqual () => binary_op ("le", contents, code, pc)
| Greater () => binary_op ("gt", contents, code, pc)
| GreaterEqual () => binary_op ("ge", contents, code, pc)
| Equal () => binary_op ("eq", contents, code, pc)
| NotEqual () => binary_op ("ne", contents, code, pc)
| And () => binary_op ("and", contents, code, pc)
| Or () => binary_op ("or", contents, code, pc)
end
and
if_then (contents : node_contents_t,
code : &List0_vt code_t >> _,
pc : &ullint >> _)
: void =
case- (contents.node_right) of
| ast_node_t_nonnil contents1 =>
let
val condition = (contents.node_left)
and true_branch = (contents1.node_left)
and false_branch = (contents1.node_right)

(* Generate code to evaluate the condition. *)
val () = traverse (condition, code, pc);

(* Generate a conditional jump. Where it goes to will be
filled in later. *)
val pjump = add_jump ("jz", code, pc)

(* Generate code for the true branch. *)
val () = traverse (true_branch, code, pc);
in
case+ false_branch of
| ast_node_t_nil () =>
begin (* There is no false branch. *)
(* Fill in the conditional jump to come here. *)
fill_jump (pjump, pc)
end
| ast_node_t_nonnil _ =>
let (* There is a false branch. *)
(* Generate an unconditional jump. Where it goes to will
be filled in later. *)
val pjump1 = add_jump ("jmp", code, pc)

(* Fill in the conditional jump to come here. *)
val () = fill_jump (pjump, pc)

(* Generate code for the false branch. *)
val () = traverse (false_branch, code, pc);

(* Fill in the unconditional jump to come here. *)
val () = fill_jump (pjump1, pc)
in
end
end
and
while_do (contents : node_contents_t,
code : &List0_vt code_t >> _,
pc : &ullint >> _)
: void =
(* I would prefer to implement ‘while’ by putting the
conditional jump at the end, and jumping to it to get into
the loop. However, we need to generate not the code of our
choice, but the reference result. The reference result has
the conditional jump at the top. *)
let
(* Where to jump from the bottom of the loop. *)
val loop_top_address = pc
(* Generate code to evaluate the condition. *)
val () = traverse (contents.node_left, code, pc)

(* Generate a conditional jump. It will be filled in later to
go past the end of the loop. *)
val pjump = add_jump ("jz", code, pc)

(* Generate code for the loop body. *)
val () = traverse (contents.node_right, code, pc)

(* Generate a jump to the top of the loop. *)
val () = add_filled_jump ("jmp", loop_top_address, code, pc)

(* Fill in the conditional jump to come here. *)
val () = fill_jump (pjump, pc)
in
end
and
sequence (contents : node_contents_t,
code : &List0_vt code_t >> _,
pc : &ullint >> _)
: void =
begin
traverse (contents.node_left, code, pc);
traverse (contents.node_right, code, pc)
end
and
assign (contents : node_contents_t,
code : &List0_vt code_t >> _,
pc : &ullint >> _)
: void =
case- contents.node_left of
| ast_node_t_nonnil ident_contents =>
let
val variable_no = ident_contents.node_arg
in
traverse (contents.node_right, code, pc);
add_instruction ("store", g0u2i variable_no, 5U, code, pc)
end
and
immediate (opcode : string,
contents : node_contents_t,
code : &List0_vt code_t >> _,
pc : &ullint >> _)
: void =
add_instruction (opcode, g0u2i (contents.node_arg), 5U,
code, pc)
and
unary_op (opcode : string,
contents : node_contents_t,
code : &List0_vt code_t >> _,
pc : &ullint >> _)
: void =
begin
traverse (contents.node_left, code, pc);
add_instruction (opcode, g0i2i ARBITRARY_INSTRUCTION_ARG, 1U,
code, pc)
end
and
binary_op (opcode : string,
contents : node_contents_t,
code : &List0_vt code_t >> _,
pc : &ullint >> _)
: void =
begin
traverse (contents.node_left, code, pc);
traverse (contents.node_right, code, pc);
add_instruction (opcode, g0i2i ARBITRARY_INSTRUCTION_ARG, 1U,
code, pc)
end

var code : List_vt code_t = NIL
var pc : ullint = g0i2u 0
in
traverse (ast, code, pc);
add_instruction ("halt", g0i2i ARBITRARY_INSTRUCTION_ARG, 1U,
code, pc);

(* The code is a cons-list, in decreasing-address order, so
reverse it to put the instructions in increasing-address
order. *)
list_vt_reverse code
end

fn
print_code (outf : FILEref,
code : !List_vt code_t)
: void =
let
fun
loop {n : nat}
.<n>.
(code : !list_vt (code_t, n))
: void =
case+ code of
| NIL => ()
| ref_instr :: tail =>
let
val @{
address = address,
opcode = opcode,
arg = arg
} = !ref_instr
in
fprint! (outf, address, " ");
fprint! (outf, opcode);
if opcode = "push" then
fprint! (outf, " ", arg)
else if opcode = "fetch" || opcode = "store" then
fprint! (outf, " [", arg, "]")
else if opcode = "jmp" || opcode = "jz" then
begin
fprint! (outf, " (", arg, ") ");
if arg < g1i2i 0 then
let
val offset : ullint = g0i2u (~arg)
val () = assertloc (offset <= succ address)
in
fprint! (outf, succ address - offset)
end
else
let
val offset : ullint = g0i2u arg
in
fprint! (outf, succ address + offset)
end
end;
fprintln! (outf);
loop tail
end

prval () = lemma_list_vt_param code
in
loop code
end

(*------------------------------------------------------------------*)

fn
main_program (inpf : FILEref,
outf : FILEref)
: int =
let
var idents : List_vt string = NIL
var strings : List_vt string = NIL

val ast = load_ast (inpf, idents, strings)
val code = generate_code ast

val () = fprintln! (outf, "Datasize: ", length idents,
" Strings: ", length strings)
val () = print_strings (outf, strings)
val () = print_code (outf, code)

val () = free idents
and () = free strings
and () = free code
in
0
end

implement
main (argc, argv) =
let
val inpfname =
if 2 <= argc then
$UN.cast{string} argv[1]
else
"-"
val outfname =
if 3 <= argc then
$UN.cast{string} argv[2]
else
"-"
val inpf =
if (inpfname : string) = "-" then
stdin_ref
else
fileref_open_exn (inpfname, file_mode_r)

val outf =
if (outfname : string) = "-" then
stdout_ref
else
fileref_open_exn (outfname, file_mode_w)
in
main_program (inpf, outf)
end

(*------------------------------------------------------------------*)
</syntaxhighlight>

{{out|case=count}}
<pre>$ patscc -o gen -O3 -DATS_MEMALLOC_GCBDW gen-in-ATS.dats -latslib -lgc && ./gen < count.ast
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
</pre>
</pre>


=={{header|AWK}}==
=={{header|AWK}}==
Tested with gawk 4.1.1 and mawk 1.3.4.
Tested with gawk 4.1.1 and mawk 1.3.4.
<syntaxhighlight lang="awk">
<lang AWK>
function error(msg) {
function error(msg) {
printf("%s\n", msg)
printf("%s\n", msg)
Line 1,276: Line 2,250:
list_code()
list_code()
}
}
</syntaxhighlight>
</lang>
{{out|case=count}}
{{out|case=count}}
<b>
<b>
Line 1,304: Line 2,278:
=={{header|C}}==
=={{header|C}}==
Tested with gcc 4.81 and later, compiles warning free with -Wall -Wextra
Tested with gcc 4.81 and later, compiles warning free with -Wall -Wextra
<lang C>#include <stdlib.h>
<syntaxhighlight lang="c">#include <stdlib.h>
#include <stdio.h>
#include <stdio.h>
#include <string.h>
#include <string.h>
Line 1,677: Line 2,651:


return 0;
return 0;
}</lang>
}</syntaxhighlight>


{{out|case=While counter example}}
{{out|case=While counter example}}
Line 1,707: Line 2,681:
Code by Steve Williams. Tested with GnuCOBOL 2.2.
Code by Steve Williams. Tested with GnuCOBOL 2.2.


<lang cobol> >>SOURCE FORMAT IS FREE
<syntaxhighlight lang="cobol"> >>SOURCE FORMAT IS FREE
identification division.
identification division.
*> this code is dedicated to the public domain
*> this code is dedicated to the public domain
Line 2,358: Line 3,332:
.
.
end program showhex.
end program showhex.
end program generator.</lang>
end program generator.</syntaxhighlight>


{{out|case=Count}}
{{out|case=Count}}
Line 2,386: Line 3,360:
=={{header|Forth}}==
=={{header|Forth}}==
Tested with Gforth 0.7.3
Tested with Gforth 0.7.3
<lang Forth>CREATE BUF 0 ,
<syntaxhighlight lang="forth">CREATE BUF 0 ,
: PEEK BUF @ 0= IF KEY BUF ! THEN BUF @ ;
: PEEK BUF @ 0= IF KEY BUF ! THEN BUF @ ;
: GETC PEEK 0 BUF ! ;
: GETC PEEK 0 BUF ! ;
Line 2,514: Line 3,488:
DUP 5 < IF CELLS .INT + @ EXECUTE ELSE DROP THEN CR
DUP 5 < IF CELLS .INT + @ EXECUTE ELSE DROP THEN CR
REPEAT DROP R> DROP ;
REPEAT DROP R> DROP ;
GENERATE EMIT BYE</lang>
GENERATE EMIT BYE</syntaxhighlight>
Passes all tests.
Passes all tests.


=={{header|Fortran}}==
{{works with|gfortran|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.

<syntaxhighlight 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).
!!!
#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

#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

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

{{out}}
$ ./lex compiler-tests/count.t | ./parse | ./gen
<pre>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</pre>

=={{header|Go}}==
{{trans|C}}
<syntaxhighlight 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()
}</syntaxhighlight>

{{out}}
while counter example:
<pre>
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
</pre>

=={{header|J}}==

Implementation:
<syntaxhighlight 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=:{{
if.#$y do.num=. _ ".y
else.num=. y end.
r=. #object
object=: object,(4#256)#:num
r
}}

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=: {{echo y throw.}}
getint=: _2147483648+4294967296|2147483648+256#.]

list_code=: {{
r=.'Datasize: %d Strings: %d\n' sprintf vars;&#strings
r=.r,;strings,each LF
pc=. 0
lim=.<:#object
while.do.
op=.(pc{object){::opcodes
r=.r,'%5d %s'sprintf pc;op
pc=. pc+1
i=. getint (lim<.pc+i.4){object
k=. 0
select.op
case.fetch;store do.k=.4[r=.r,' [%d]'sprintf i
case.push do.k=.4[r=.r,' %d'sprintf i
case.jmp;jz do.k=.4[r=.r,' (%d) %d'sprintf (i-pc);i
case.halt do.r=.r,LF return.
end.
pc=.pc+k
r=.r,LF
end.
}}

gen=: {{
object=:strings=:vars=:i.0
gen_code load_ast y
list_code gen_op halt
}}</syntaxhighlight>

Count example:
<syntaxhighlight 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
</syntaxhighlight>

=={{header|Java}}==
{{trans|Python}}
<syntaxhighlight 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());
}
}
}
}
</syntaxhighlight>


=={{header|Julia}}==
=={{header|Julia}}==
<lang julia>import Base.show
<syntaxhighlight lang="julia">import Base.show


mutable struct Asm32
mutable struct Asm32
Line 2,681: Line 6,502:


compiletoasm(iob)
compiletoasm(iob)
</lang>{{output}}<pre>
</syntaxhighlight>{{output}}<pre>
Datasize: 1 Strings: 2
Datasize: 1 Strings: 2
"count is: "
"count is: "
Line 2,706: Line 6,527:


=={{header|M2000 Interpreter}}==
=={{header|M2000 Interpreter}}==
<syntaxhighlight lang="m2000 interpreter">
<lang M2000 Interpreter>
Module CodeGenerator (s$){
Module CodeGenerator (s$){
Function code$(op$) {
Function code$(op$) {
Line 2,733: Line 6,554:
Append symb, "LessEqual":=gle, "Greater":=ggt, "GreaterEqual":=gge, "Sequence":=gSeq
Append symb, "LessEqual":=gle, "Greater":=ggt, "GreaterEqual":=gge, "Sequence":=gSeq
Append symb, "Equal":=geq, "NotEqual":=gne, "And":=gand, "Or":=gor, "While":=gwhile
Append symb, "Equal":=geq, "NotEqual":=gne, "And":=gand, "Or":=gor, "While":=gwhile
Append symb, "Putc":=gprtc,"Prti":=gprti,"Prts":=gprts, "Assign":=gAssign, "If":=gif
Append symb, "Prtc":=gprtc,"Prti":=gprti,"Prts":=gprts, "Assign":=gAssign, "If":=gif
Append symb, "String":=gstring, "Identifier":=gidentifier, "Integer":=gint, ";", gnone
Append symb, "String":=gstring, "Identifier":=gidentifier, "Integer":=gint, ";", gnone


Line 2,770: Line 6,591:
\\ Let's make the header
\\ Let's make the header
Header$=format$("Datasize: {0} Strings: {1}", Len(Dataset),Len(strings))+nl$
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.
\\ we use an iterator object, str^ is the counter, readonly, but Eval$() use it from object.
str=each(strings)
str=each(strings)
While str
While str
Header$=Eval$(str)
Header$=nl$+Eval$(str)
If str^<len(strings)-1 then Header$=nl$
End while
End while
Assembly$=nl$
\\ insert to line 1 the Header
\\ insert to line 1 the Header
Insert 1 Assembly$=Header$
Insert 1 Assembly$=Header$
Line 2,816: Line 6,637:
data code3$("jz",pc1, pc1, pc)
data code3$("jz",pc1, pc1, pc)
CodeGenerator(t#val(2)#val(2))
CodeGenerator(t#val(2)#val(2))
data code3$("jz",pc2, pc2, pc)
data code3$("jmp",pc2, pc2, pc)
else
else
data code3$("jz",pc1, pc1, pc)
data code3$("jz",pc1, pc1, pc)
Line 2,880: Line 6,701:
until line$<>"" or i>=lim
until line$<>"" or i>=lim
If tok$="Identifier" then
If tok$="Identifier" then
Push (gidentifier, piece$(line$," ")(1))
Push (gidentifier,trim$(Mid$(line$,11)))
else.if tok$="Integer" then
else.if tok$="Integer" then
long n=Val(piece$(line$," ")(1)) ' check overflow
long n=Val(Mid$(line$,8)) ' check overflow
Push (gint, piece$(line$," ")(1))
Push (gint, Trim$(Mid$(line$,8)))
else.if tok$="String" then
else.if tok$="String" then
Push (gstring,Trim$(Mid$(line$,7)))
Push (gstring,Trim$(Mid$(line$,7)))
Line 2,931: Line 6,752:
Integer 1
Integer 1
}
}
</syntaxhighlight>
</lang>


{{out}}
{{out}}
Line 2,957: Line 6,778:
65 halt
65 halt
</pre >
</pre >

=={{header|Nim}}==

<syntaxhighlight 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]


####################################################################################################
# Code generator.

proc genSimpleInst(gen: var CodeGen; opcode: OpCode) =
## Build a simple instruction (no operand).
gen.instr.add &"{gen.address:>5} {opcode}"

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

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}]"

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

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"

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

proc genPush(gen: var CodeGen; value: int) =
## Build a push instruction.
gen.instr.add &"{gen.address:>5} {opPush:<5} {value}"

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

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

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

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)

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

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

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

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

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)


#———————————————————————————————————————————————————————————————————————————————————————————————————

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)</syntaxhighlight>

{{out}}
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).

<pre>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</pre>


=={{header|Perl}}==
=={{header|Perl}}==
Tested with perl v5.26.1
Tested with perl v5.26.1
<lang Perl>#!/usr/bin/perl
<syntaxhighlight lang="perl">#!/usr/bin/perl


use strict; # gen.pl - flatAST to stack machine code
use strict; # gen.pl - flatAST to stack machine code
Line 2,999: Line 7,244:
print "Datasize: $namecount Strings: $stringcount\n";
print "Datasize: $namecount Strings: $stringcount\n";
print "$_\n" for sort { $strings{$a} <=> $strings{$b} } keys %strings;
print "$_\n" for sort { $strings{$a} <=> $strings{$b} } keys %strings;
print;</lang>
print;</syntaxhighlight>
Passes all tests.
Passes all tests.


Line 3,005: Line 7,250:
Reusing parse.e from the [[Compiler/syntax_analyzer#Phix|Syntax Analyzer task]]<br>
Reusing parse.e from the [[Compiler/syntax_analyzer#Phix|Syntax Analyzer task]]<br>
Deviates somewhat from the task specification in that it generates executable machine code.
Deviates somewhat from the task specification in that it generates executable machine code.
<!--<syntaxhighlight lang="phix">(notonline)-->
<lang Phix>--
<span style="color: #000080;font-style:italic;">--
-- demo\rosetta\Compiler\cgen.e
-- demo\rosetta\Compiler\cgen.e
-- ============================
-- ============================
--
--
-- The reusable part of cgen.exw
-- The reusable part of cgen.exw
--
--</span>

<span style="color: #008080;">without</span> <span style="color: #008080;">js</span> <span style="color: #000080;font-style:italic;">-- (machine code!)</span>
include parse.e
<span style="color: #008080;">include</span> <span style="color: #000000;">parse</span><span style="color: #0000FF;">.</span><span style="color: #000000;">e</span>

global sequence vars = {},
<span style="color: #008080;">global</span> <span style="color: #004080;">sequence</span> <span style="color: #000000;">vars</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{},</span>
strings = {},
<span style="color: #000000;">strings</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{},</span>
stringptrs = {}
<span style="color: #000000;">stringptrs</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{}</span>

global integer chain = 0
<span style="color: #008080;">global</span> <span style="color: #004080;">integer</span> <span style="color: #000000;">chain</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">0</span>
global sequence code = {}
<span style="color: #008080;">global</span> <span style="color: #004080;">sequence</span> <span style="color: #000000;">code</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{}</span>

function var_idx(sequence inode)
<span style="color: #008080;">function</span> <span style="color: #000000;">var_idx</span><span style="color: #0000FF;">(</span><span style="color: #004080;">sequence</span> <span style="color: #000000;">inode</span><span style="color: #0000FF;">)</span>
if inode[1]!=tk_Identifier then ?9/0 end if
<span style="color: #008080;">if</span> <span style="color: #000000;">inode</span><span style="color: #0000FF;">[</span><span style="color: #000000;">1</span><span style="color: #0000FF;">]!=</span><span style="color: #000000;">tk_Identifier</span> <span style="color: #008080;">then</span> <span style="color: #0000FF;">?</span><span style="color: #000000;">9</span><span style="color: #0000FF;">/</span><span style="color: #000000;">0</span> <span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
string ident = inode[2]
<span style="color: #004080;">string</span> <span style="color: #000000;">ident</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">inode</span><span style="color: #0000FF;">[</span><span style="color: #000000;">2</span><span style="color: #0000FF;">]</span>
integer n = find(ident,vars)
<span style="color: #004080;">integer</span> <span style="color: #000000;">n</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">find</span><span style="color: #0000FF;">(</span><span style="color: #000000;">ident</span><span style="color: #0000FF;">,</span><span style="color: #000000;">vars</span><span style="color: #0000FF;">)</span>
if n=0 then
<span style="color: #008080;">if</span> <span style="color: #000000;">n</span><span style="color: #0000FF;">=</span><span style="color: #000000;">0</span> <span style="color: #008080;">then</span>
vars = append(vars,ident)
<span style="color: #000000;">vars</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">append</span><span style="color: #0000FF;">(</span><span style="color: #000000;">vars</span><span style="color: #0000FF;">,</span><span style="color: #000000;">ident</span><span style="color: #0000FF;">)</span>
n = length(vars)
<span style="color: #000000;">n</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">vars</span><span style="color: #0000FF;">)</span>
end if
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
return n
<span style="color: #008080;">return</span> <span style="color: #000000;">n</span>
end function
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>

function string_idx(sequence inode)
<span style="color: #008080;">function</span> <span style="color: #000000;">string_idx</span><span style="color: #0000FF;">(</span><span style="color: #004080;">sequence</span> <span style="color: #000000;">inode</span><span style="color: #0000FF;">)</span>
if inode[1]!=tk_String then ?9/0 end if
<span style="color: #008080;">if</span> <span style="color: #000000;">inode</span><span style="color: #0000FF;">[</span><span style="color: #000000;">1</span><span style="color: #0000FF;">]!=</span><span style="color: #000000;">tk_String</span> <span style="color: #008080;">then</span> <span style="color: #0000FF;">?</span><span style="color: #000000;">9</span><span style="color: #0000FF;">/</span><span style="color: #000000;">0</span> <span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
string s = inode[2]
<span style="color: #004080;">string</span> <span style="color: #000000;">s</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">inode</span><span style="color: #0000FF;">[</span><span style="color: #000000;">2</span><span style="color: #0000FF;">]</span>
integer n = find(s,strings)
<span style="color: #004080;">integer</span> <span style="color: #000000;">n</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">find</span><span style="color: #0000FF;">(</span><span style="color: #000000;">s</span><span style="color: #0000FF;">,</span><span style="color: #000000;">strings</span><span style="color: #0000FF;">)</span>
if n=0 then
<span style="color: #008080;">if</span> <span style="color: #000000;">n</span><span style="color: #0000FF;">=</span><span style="color: #000000;">0</span> <span style="color: #008080;">then</span>
strings = append(strings,s)
<span style="color: #000000;">strings</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">append</span><span style="color: #0000FF;">(</span><span style="color: #000000;">strings</span><span style="color: #0000FF;">,</span><span style="color: #000000;">s</span><span style="color: #0000FF;">)</span>
stringptrs = append(stringptrs,0)
<span style="color: #000000;">stringptrs</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">append</span><span style="color: #0000FF;">(</span><span style="color: #000000;">stringptrs</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0</span><span style="color: #0000FF;">)</span>
n = length(strings)
<span style="color: #000000;">n</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">strings</span><span style="color: #0000FF;">)</span>
end if
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
return n
<span style="color: #008080;">return</span> <span style="color: #000000;">n</span>
end function
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>

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

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

<span style="color: #000000;">0o061</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0o300</span><span style="color: #0000FF;">,</span> <span style="color: #000080;font-style:italic;">-- xor eax,eax</span>
global procedure code_gen(object t)
<span style="color: #000000;">0o205</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0o322</span><span style="color: #0000FF;">,</span> <span style="color: #000080;font-style:italic;">-- test edx,edx</span>
--
<span style="color: #000000;">0o017</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0o224</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0o300</span><span style="color: #0000FF;">,</span> <span style="color: #000080;font-style:italic;">-- setz al</span>
-- Generates proper machine code.
<span style="color: #000000;">0o120</span><span style="color: #0000FF;">}</span> <span style="color: #000080;font-style:italic;">-- push eax</span>
--
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_neg</span><span style="color: #0000FF;">:</span>
-- Example: i=10; print "\n"; print i; print "\n"
<span style="color: #000000;">gen_rec</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t</span><span style="color: #0000FF;">[</span><span style="color: #000000;">2</span><span style="color: #0000FF;">])</span>
-- Result in vars, strings, chain, code (declared above)
<span style="color: #000000;">code</span> <span style="color: #0000FF;">&=</span> <span style="color: #0000FF;">{</span><span style="color: #000000;">0o130</span><span style="color: #0000FF;">,</span> <span style="color: #000080;font-style:italic;">-- pop eax</span>
-- where vars is: {"i"},
<span style="color: #000000;">0o367</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0o330</span><span style="color: #0000FF;">,</span> <span style="color: #000080;font-style:italic;">-- neg eax</span>
-- strings is {"\n"},
<span style="color: #000000;">0o120</span><span style="color: #0000FF;">}</span> <span style="color: #000080;font-style:italic;">-- push eax</span>
-- code is { 0o150,#0A,#00,#00,#00, -- 1: push 10
<span style="color: #008080;">else</span><span style="color: #0000FF;">:</span>
-- 0o217,0o005,0,1,1,0 -- 6: pop [i]
<span style="color: #000000;">error</span><span style="color: #0000FF;">(</span><span style="color: #008000;">"error in code generator - found %d, expecting operator\n"</span><span style="color: #0000FF;">,</span> <span style="color: #0000FF;">{</span><span style="color: #000000;">n_type</span><span style="color: #0000FF;">})</span>
-- 0o150,8,2,1,0, -- 12: push ("\n")
<span style="color: #008080;">end</span> <span style="color: #008080;">switch</span>
-- 0o350,13,3,3,0, -- 17: call :prints
<span style="color: #004080;">integer</span> <span style="color: #000000;">actsize</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">code</span><span style="color: #0000FF;">)</span>
-- 0o377,0o065,18,1,1,0, -- 22: push [i]
<span style="color: #008080;">if</span> <span style="color: #000000;">initsize</span><span style="color: #0000FF;">+</span><span style="color: #000000;">estsize</span><span style="color: #0000FF;">!=</span><span style="color: #000000;">actsize</span> <span style="color: #008080;">then</span> <span style="color: #0000FF;">?</span><span style="color: #008000;">"9/0"</span> <span style="color: #008080;">end</span> <span style="color: #008080;">if</span> <span style="color: #000080;font-style:italic;">-- (test gen_size)</span>
-- 0o350,24,3,2,0, -- 28: call :printi
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
-- 0o150,29,2,1,0, -- 33: push ("\n")
<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
-- 0o350,34,3,3,0, -- 38: call :prints
-- 0o303} -- 43: ret
<span style="color: #008080;">global</span> <span style="color: #008080;">procedure</span> <span style="color: #000000;">code_gen</span><span style="color: #0000FF;">(</span><span style="color: #004080;">object</span> <span style="color: #000000;">t</span><span style="color: #0000FF;">)</span>
-- and chain is 39 (->34->29->24->18->13->8->0)
<span style="color: #000080;font-style:italic;">--
-- The chain connects all places where we need an actual address before
-- Generates proper machine code.
-- the code is executed, with the byte after the link differentiating
--
-- between var(1), string(2), and builtin(3), and the byte after that
-- Example: i=10; print "\n"; print i; print "\n"
-- determining the instance of the given type - not that any of them
-- Result in vars, strings, chain, code (declared above)
-- are actually limited to a byte in the above intermediate form, and
-- where vars is: {"i"},
-- of course the trailing 0 of each {link,type,id,0} is just there to
-- strings is {"\n"},
-- reserve the space we will need.
-- code is { 0o150,#0A,#00,#00,#00, -- 1: push 10
--
-- 0o217,0o005,0,1,1,0 -- 6: pop [i]
gen_rec(t)
-- 0o150,8,2,1,0, -- 12: push ("\n")
code = append(code,0o303) -- ret (0o303=#C3)
-- 0o350,13,3,3,0, -- 17: call :prints
end procedure
-- 0o377,0o065,18,1,1,0, -- 22: push [i]

-- 0o350,24,3,2,0, -- 28: call :printi
include builtins/VM/puts1.e -- low-level console i/o routines
-- 0o150,29,2,1,0, -- 33: push ("\n")

-- 0o350,34,3,3,0, -- 38: call :prints
function setbuiltins()
-- 0o303} -- 43: ret
atom printc,printi,prints
-- and chain is 39 (-&gt;34-&gt;29-&gt;24-&gt;18-&gt;13-&gt;8-&gt;0)
#ilASM{
-- The chain connects all places where we need an actual address before
jmp :setbuiltins
-- the code is executed, with the byte after the link differentiating
::printc
-- between var(1), string(2), and builtin(3), and the byte after that
lea edi,[esp+4]
-- determining the instance of the given type - not that any of them
mov esi,1
-- are actually limited to a byte in the above intermediate form, and
call :%puts1ediesi -- (edi=raw text, esi=length)
-- of course the trailing 0 of each {link,type,id,0} is just there to
ret 4
-- reserve the space we will need.
::printi
--</span>
mov eax,[esp+4]
<span style="color: #000000;">gen_rec</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t</span><span style="color: #0000FF;">)</span>
push 0 -- no cr
<span style="color: #000000;">code</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">append</span><span style="color: #0000FF;">(</span><span style="color: #000000;">code</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0o303</span><span style="color: #0000FF;">)</span> <span style="color: #000080;font-style:italic;">-- ret (0o303=#C3)</span>
call :%putsint -- (nb limited to +/-9,999,999,999)
<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
ret 4
::prints
<span style="color: #008080;">include</span> <span style="color: #000000;">builtins</span><span style="color: #0000FF;">/</span><span style="color: #000000;">VM</span><span style="color: #0000FF;">/</span><span style="color: #000000;">puts1</span><span style="color: #0000FF;">.</span><span style="color: #000000;">e</span> <span style="color: #000080;font-style:italic;">-- low-level console i/o routines</span>
mov edi,[esp+4]
mov esi,[edi-12]
<span style="color: #008080;">function</span> <span style="color: #000000;">setbuiltins</span><span style="color: #0000FF;">()</span>
call :%puts1ediesi -- (edi=raw text, esi=length)
<span style="color: #004080;">atom</span> <span style="color: #000000;">printc</span><span style="color: #0000FF;">,</span><span style="color: #000000;">printi</span><span style="color: #0000FF;">,</span><span style="color: #000000;">prints</span>
ret 4
::setbuiltins
#ilASM{
mov eax,:printc
jmp :setbuiltins
lea edi,[printc]
::printc
call :%pStoreMint
lea edi,[esp+4]
mov eax,:printi
mov esi,1
lea edi,[printi]
call :%puts1ediesi -- (edi=raw text, esi=length)
call :%pStoreMint
ret 4
mov eax,:prints
::printi
lea edi,[prints]
mov eax,[esp+4]
call :%pStoreMint
push 0 -- no cr
call :%putsint -- (nb limited to +/-9,999,999,999)
}
ret 4
return {printc,printi,prints}
::prints
end function
mov edi,[esp+4]

mov esi,[edi-12]
global constant builtin_names = {"printc","printi","prints"}
call :%puts1ediesi -- (edi=raw text, esi=length)
global constant builtins = setbuiltins()
ret 4

::setbuiltins
global atom var_mem, code_mem
mov eax,:printc

lea edi,[printc]
function RawStringPtr(integer n) -- (based on IupRawStringPtr from pGUI.e)
call :%pStoreMint
--
mov eax,:printi
-- Returns a raw string pointer for s, somewhat like allocate_string(s), but using the existing memory.
lea edi,[printi]
-- NOTE: The return is only valid as long as the value passed as the parameter remains in existence.
call :%pStoreMint
--
mov eax,:prints
atom res
string s = strings[n]
lea edi,[prints]
call :%pStoreMint
#ilASM{
mov eax,[s]
}
<span style="color: #008080;">return</span> <span style="color: #0000FF;">{</span><span style="color: #000000;">printc</span><span style="color: #0000FF;">,</span><span style="color: #000000;">printi</span><span style="color: #0000FF;">,</span><span style="color: #000000;">prints</span><span style="color: #0000FF;">}</span>
lea edi,[res]
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
shl eax,2
call :%pStoreMint
<span style="color: #008080;">global</span> <span style="color: #008080;">constant</span> <span style="color: #000000;">builtin_names</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{</span><span style="color: #008000;">"printc"</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"printi"</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"prints"</span><span style="color: #0000FF;">}</span>
}
<span style="color: #008080;">global</span> <span style="color: #008080;">constant</span> <span style="color: #000000;">builtins</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">setbuiltins</span><span style="color: #0000FF;">()</span>
stringptrs[n] = res
return res
<span style="color: #008080;">global</span> <span style="color: #004080;">atom</span> <span style="color: #000000;">var_mem</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">code_mem</span>
end function

<span style="color: #008080;">function</span> <span style="color: #000000;">RawStringPtr</span><span style="color: #0000FF;">(</span><span style="color: #004080;">integer</span> <span style="color: #000000;">n</span><span style="color: #0000FF;">)</span> <span style="color: #000080;font-style:italic;">-- (based on IupRawStringPtr from pGUI.e)
global procedure fixup()
--
var_mem = allocate(length(vars)*4)
-- Returns a raw string pointer for s, somewhat like allocate_string(s), but using the existing memory.
mem_set(var_mem,0,length(vars)*4)
-- NOTE: The return is only valid as long as the value passed as the parameter remains in existence.
code_mem = allocate(length(code))
--</span>
poke(code_mem,code)
<span style="color: #004080;">atom</span> <span style="color: #000000;">res</span>
while chain!=0 do
<span style="color: #004080;">string</span> <span style="color: #000000;">s</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">strings</span><span style="color: #0000FF;">[</span><span style="color: #000000;">n</span><span style="color: #0000FF;">]</span>
integer this = chain
#ilASM{
chain = code[this]
integer ftype = code[this+1]
mov eax,[s]
integer id = code[this+2]
lea edi,[res]
switch ftype do
shl eax,2
case 1: -- vars
call :%pStoreMint
}
poke4(code_mem+this-1,var_mem+(id-1)*4)
<span style="color: #000000;">stringptrs</span><span style="color: #0000FF;">[</span><span style="color: #000000;">n</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">res</span>
case 2: -- strings
<span style="color: #008080;">return</span> <span style="color: #000000;">res</span>
poke4(code_mem+this-1,RawStringPtr(id))
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
case 3: -- builtins
poke4(code_mem+this-1,builtins[id]-(code_mem+this+3))
<span style="color: #008080;">global</span> <span style="color: #008080;">procedure</span> <span style="color: #000000;">fixup</span><span style="color: #0000FF;">()</span>
end switch
<span style="color: #000000;">var_mem</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">allocate</span><span style="color: #0000FF;">(</span><span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">vars</span><span style="color: #0000FF;">)*</span><span style="color: #000000;">4</span><span style="color: #0000FF;">)</span>
end while
<span style="color: #7060A8;">mem_set</span><span style="color: #0000FF;">(</span><span style="color: #000000;">var_mem</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0</span><span style="color: #0000FF;">,</span><span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">vars</span><span style="color: #0000FF;">)*</span><span style="color: #000000;">4</span><span style="color: #0000FF;">)</span>
end procedure</lang>
<span style="color: #000000;">code_mem</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">allocate</span><span style="color: #0000FF;">(</span><span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">code</span><span style="color: #0000FF;">))</span>
<span style="color: #7060A8;">poke</span><span style="color: #0000FF;">(</span><span style="color: #000000;">code_mem</span><span style="color: #0000FF;">,</span><span style="color: #000000;">code</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">while</span> <span style="color: #000000;">chain</span><span style="color: #0000FF;">!=</span><span style="color: #000000;">0</span> <span style="color: #008080;">do</span>
<span style="color: #004080;">integer</span> <span style="color: #7060A8;">this</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">chain</span>
<span style="color: #000000;">chain</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">code</span><span style="color: #0000FF;">[</span><span style="color: #7060A8;">this</span><span style="color: #0000FF;">]</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">ftype</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">code</span><span style="color: #0000FF;">[</span><span style="color: #7060A8;">this</span><span style="color: #0000FF;">+</span><span style="color: #000000;">1</span><span style="color: #0000FF;">]</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">id</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">code</span><span style="color: #0000FF;">[</span><span style="color: #7060A8;">this</span><span style="color: #0000FF;">+</span><span style="color: #000000;">2</span><span style="color: #0000FF;">]</span>
<span style="color: #008080;">switch</span> <span style="color: #000000;">ftype</span> <span style="color: #008080;">do</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">1</span><span style="color: #0000FF;">:</span> <span style="color: #000080;font-style:italic;">-- vars</span>
<span style="color: #7060A8;">poke4</span><span style="color: #0000FF;">(</span><span style="color: #000000;">code_mem</span><span style="color: #0000FF;">+</span><span style="color: #7060A8;">this</span><span style="color: #0000FF;">-</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #000000;">var_mem</span><span style="color: #0000FF;">+(</span><span style="color: #000000;">id</span><span style="color: #0000FF;">-</span><span style="color: #000000;">1</span><span style="color: #0000FF;">)*</span><span style="color: #000000;">4</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">2</span><span style="color: #0000FF;">:</span> <span style="color: #000080;font-style:italic;">-- strings</span>
<span style="color: #7060A8;">poke4</span><span style="color: #0000FF;">(</span><span style="color: #000000;">code_mem</span><span style="color: #0000FF;">+</span><span style="color: #7060A8;">this</span><span style="color: #0000FF;">-</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #000000;">RawStringPtr</span><span style="color: #0000FF;">(</span><span style="color: #000000;">id</span><span style="color: #0000FF;">))</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">3</span><span style="color: #0000FF;">:</span> <span style="color: #000080;font-style:italic;">-- builtins</span>
<span style="color: #7060A8;">poke4</span><span style="color: #0000FF;">(</span><span style="color: #000000;">code_mem</span><span style="color: #0000FF;">+</span><span style="color: #7060A8;">this</span><span style="color: #0000FF;">-</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #000000;">builtins</span><span style="color: #0000FF;">[</span><span style="color: #000000;">id</span><span style="color: #0000FF;">]-(</span><span style="color: #000000;">code_mem</span><span style="color: #0000FF;">+</span><span style="color: #7060A8;">this</span><span style="color: #0000FF;">+</span><span style="color: #000000;">3</span><span style="color: #0000FF;">))</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">switch</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">while</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
<!--</syntaxhighlight>-->
And a simple test driver for the specific task:
And a simple test driver for the specific task:
<!--<syntaxhighlight lang="phix">(notonline)-->
<lang Phix>--
<span style="color: #000080;font-style:italic;">--
-- demo\rosetta\Compiler\cgen.exw
-- demo\rosetta\Compiler\cgen.exw
-- ==============================
-- ==============================
--
--
-- Generates 32-bit machine code (see note in vm.exw)
-- Generates 32-bit machine code (see note in vm.exw)
--
--</span>

<span style="color: #008080;">without</span> <span style="color: #008080;">js</span> <span style="color: #000080;font-style:italic;">-- (machine code!)</span>
include cgen.e
<span style="color: #008080;">include</span> <span style="color: #000000;">cgen</span><span style="color: #0000FF;">.</span><span style="color: #000000;">e</span>

function get_var_name(atom addr)
<span style="color: #008080;">function</span> <span style="color: #000000;">get_var_name</span><span style="color: #0000FF;">(</span><span style="color: #004080;">atom</span> <span style="color: #000000;">addr</span><span style="color: #0000FF;">)</span>
integer n = (addr-var_mem)/4+1
<span style="color: #004080;">integer</span> <span style="color: #000000;">n</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">(</span><span style="color: #000000;">addr</span><span style="color: #0000FF;">-</span><span style="color: #000000;">var_mem</span><span style="color: #0000FF;">)/</span><span style="color: #000000;">4</span><span style="color: #0000FF;">+</span><span style="color: #000000;">1</span>
if n<1 or n>length(vars) then ?9/0 end if
<span style="color: #008080;">if</span> <span style="color: #000000;">n</span><span style="color: #0000FF;"><</span><span style="color: #000000;">1</span> <span style="color: #008080;">or</span> <span style="color: #000000;">n</span><span style="color: #0000FF;">></span><span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">vars</span><span style="color: #0000FF;">)</span> <span style="color: #008080;">then</span> <span style="color: #0000FF;">?</span><span style="color: #000000;">9</span><span style="color: #0000FF;">/</span><span style="color: #000000;">0</span> <span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
return vars[n]
<span style="color: #008080;">return</span> <span style="color: #000000;">vars</span><span style="color: #0000FF;">[</span><span style="color: #000000;">n</span><span style="color: #0000FF;">]</span>
end function
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>

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

constant cccodes = {"o?" ,"no?","b?" ,"ae?","z" ,"ne" ,"be?","a?",
<span style="color: #008080;">constant</span> <span style="color: #000000;">cccodes</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{</span><span style="color: #008000;">"o?"</span> <span style="color: #0000FF;">,</span><span style="color: #008000;">"no?"</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"b?"</span> <span style="color: #0000FF;">,</span><span style="color: #008000;">"ae?"</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"z"</span> <span style="color: #0000FF;">,</span><span style="color: #008000;">"ne"</span> <span style="color: #0000FF;">,</span><span style="color: #008000;">"be?"</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"a?"</span><span style="color: #0000FF;">,</span>
-- 0 , 1 , 2 , 3 , 4 , 5 , 6 , 7 ,
"s?" ,"ns?","pe?","po?","l" ,"ge" ,"le" ,"g" }
<span style="color: #000080;font-style:italic;">-- 0 , 1 , 2 , 3 , 4 , 5 , 6 , 7 ,</span>
<span style="color: #008000;">"s?"</span> <span style="color: #0000FF;">,</span><span style="color: #008000;">"ns?"</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"pe?"</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"po?"</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"l"</span> <span style="color: #0000FF;">,</span><span style="color: #008000;">"ge"</span> <span style="color: #0000FF;">,</span><span style="color: #008000;">"le"</span> <span style="color: #0000FF;">,</span><span style="color: #008000;">"g"</span> <span style="color: #0000FF;">}</span>
-- 8 , 9 , 10 , 11 , 12 , 13 , 14 , 15
<span style="color: #000080;font-style:italic;">-- 8 , 9 , 10 , 11 , 12 , 13 , 14 , 15</span>

constant regs = {"eax","ecx","edx"} -- (others as/when needed)
<span style="color: #008080;">constant</span> <span style="color: #000000;">regs</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{</span><span style="color: #008000;">"eax"</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"ecx"</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"edx"</span><span style="color: #0000FF;">}</span> <span style="color: #000080;font-style:italic;">-- (others as/when needed)</span>

procedure decode()
<span style="color: #008080;">procedure</span> <span style="color: #000000;">decode</span><span style="color: #0000FF;">()</span>
-- for a much more complete (and better organised) disassembler, see p2asm.e
<span style="color: #000080;font-style:italic;">-- for a much more complete (and better organised) disassembler, see p2asm.e</span>
integer pc = 0, -- nb 0-based
<span style="color: #004080;">integer</span> <span style="color: #000000;">pc</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">0</span><span style="color: #0000FF;">,</span> <span style="color: #000080;font-style:italic;">-- nb 0-based</span>
opcode, xrm
<span style="color: #000000;">opcode</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">xrm</span>

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

<span style="color: #008080;">exit</span>
procedure main(sequence cl)
<span style="color: #008080;">end</span> <span style="color: #008080;">switch</span>
open_files(cl)
<span style="color: #008080;">end</span> <span style="color: #008080;">while</span>
toks = lex()
<span style="color: #008080;">if</span> <span style="color: #000000;">pc</span><span style="color: #0000FF;"><</span><span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">code</span><span style="color: #0000FF;">)</span> <span style="color: #008080;">then</span>
object t = parse()
<span style="color: #0000FF;">?</span><span style="color: #008000;">"incomplete:"</span>
code_gen(t)
<span style="color: #008080;">if</span> <span style="color: #000000;">xrm</span><span style="color: #0000FF;">=-</span><span style="color: #000000;">1</span> <span style="color: #008080;">then</span>
fixup()
<span style="color: #0000FF;">?{</span><span style="color: #000000;">pc</span><span style="color: #0000FF;">+</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #7060A8;">sprintf</span><span style="color: #0000FF;">(</span><span style="color: #008000;">"0o%03o"</span><span style="color: #0000FF;">,</span><span style="color: #000000;">opcode</span><span style="color: #0000FF;">)}</span>
decode()
<span style="color: #008080;">else</span>
free({var_mem,code_mem})
<span style="color: #0000FF;">?{</span><span style="color: #000000;">pc</span><span style="color: #0000FF;">+</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #7060A8;">sprintf</span><span style="color: #0000FF;">(</span><span style="color: #008000;">"0o%03o 0o%03o"</span><span style="color: #0000FF;">,{</span><span style="color: #000000;">opcode</span><span style="color: #0000FF;">,</span><span style="color: #000000;">xrm</span><span style="color: #0000FF;">})}</span>
close_files()
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
end procedure
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>

<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
--main(command_line())
main({0,0,"gcd.c"})</lang>
<span style="color: #008080;">procedure</span> <span style="color: #000000;">main</span><span style="color: #0000FF;">(</span><span style="color: #004080;">sequence</span> <span style="color: #000000;">cl</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">open_files</span><span style="color: #0000FF;">(</span><span style="color: #000000;">cl</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">toks</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">lex</span><span style="color: #0000FF;">()</span>
<span style="color: #004080;">object</span> <span style="color: #000000;">t</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">parse</span><span style="color: #0000FF;">()</span>
<span style="color: #000000;">code_gen</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">fixup</span><span style="color: #0000FF;">()</span>
<span style="color: #000000;">decode</span><span style="color: #0000FF;">()</span>
<span style="color: #7060A8;">free</span><span style="color: #0000FF;">({</span><span style="color: #000000;">var_mem</span><span style="color: #0000FF;">,</span><span style="color: #000000;">code_mem</span><span style="color: #0000FF;">})</span>
<span style="color: #000000;">close_files</span><span style="color: #0000FF;">()</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
<span style="color: #000080;font-style:italic;">--main(command_line())</span>
<span style="color: #000000;">main</span><span style="color: #0000FF;">({</span><span style="color: #000000;">0</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"gcd.c"</span><span style="color: #0000FF;">})</span>
<!--</syntaxhighlight>-->
{{out}}
{{out}}
<pre>
<pre>
Line 3,603: Line 7,880:
=={{header|Python}}==
=={{header|Python}}==
Tested with Python 2.7 and 3.x
Tested with Python 2.7 and 3.x
<lang Python>from __future__ import print_function
<syntaxhighlight lang="python">from __future__ import print_function
import sys, struct, shlex, operator
import sys, struct, shlex, operator


Line 3,856: Line 8,133:
code_gen(n)
code_gen(n)
code_finish()
code_finish()
list_code()</lang>
list_code()</syntaxhighlight>


{{out|case=While counter example}}
{{out|case=While counter example}}
Line 3,882: Line 8,159:
65 halt</pre>
65 halt</pre>
</b>
</b>

=={{header|Raku}}==
(formerly Perl 6)
Using 'while-count' example, input used is here: [https://github.com/SqrtNegInf/Rosettacode-Perl6-Smoke/blob/master/ref/ast.txt ast.txt]
{{trans|Perl}}
<syntaxhighlight lang="raku" line>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;</syntaxhighlight>
{{out}}
<pre>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</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}}


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

######################################################################</syntaxhighlight>

{{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}}==
The complete implementation for the compiler tasks can be found in a GitHub repository at [https://github.com/edadma/rosettacodeCompiler 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 [http://rosettacode.org/wiki/Compiler/syntax_analyzer#Scala parser].

<syntaxhighlight 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"
}
)
}
}

}
</syntaxhighlight>


=={{header|Scheme}}==
=={{header|Scheme}}==


<lang scheme>
<syntaxhighlight lang="scheme">
(import (scheme base)
(import (scheme base)
(scheme file)
(scheme file)
Line 4,073: Line 10,106:
(generate-code (read-code (cadr (command-line))))
(generate-code (read-code (cadr (command-line))))
(display "Error: pass an ast filename\n"))
(display "Error: pass an ast filename\n"))
</syntaxhighlight>
</lang>


Tested on all examples in [[Compiler/Sample programs]].
Tested on all examples in [[Compiler/Sample programs]].

=={{header|Wren}}==
{{trans|Go}}
{{libheader|Wren-dynamic}}
{{libheader|Wren-crypto}}
{{libheader|Wren-fmt}}
{{libheader|Wren-ioutil}}
<syntaxhighlight lang="wren">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()</syntaxhighlight>

{{out}}
<pre>
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
</pre>

=={{header|Zig}}==
<syntaxhighlight 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;
}
}
</syntaxhighlight>


=={{header|zkl}}==
=={{header|zkl}}==
{{trans|Python}}
{{trans|Python}}
<lang zkl>// This is a little endian machine
<syntaxhighlight lang="zkl">// This is a little endian machine


const WORD_SIZE=4;
const WORD_SIZE=4;
Line 4,191: Line 11,113:
code.insert(0,66,text.len(),text);
code.insert(0,66,text.len(),text);
})
})
}</lang>
}</syntaxhighlight>
<lang zkl>fcn unasm(code){
<syntaxhighlight lang="zkl">fcn unasm(code){
all_ops,nthString := all_syms.pump(Dictionary(),"reverse"),-1;
all_ops,nthString := all_syms.pump(Dictionary(),"reverse"),-1;
println("Datasize: %d bytes, Strings: %d bytes"
println("Datasize: %d bytes, Strings: %d bytes"
Line 4,226: Line 11,148:
}
}
}
}
}</lang>
}</syntaxhighlight>
<lang zkl>fcn load_ast(file){
<syntaxhighlight lang="zkl">fcn load_ast(file){
line:=file.readln().strip(); // one or two tokens
line:=file.readln().strip(); // one or two tokens
if(line[0]==";") return(Void);
if(line[0]==";") return(Void);
Line 4,238: Line 11,160:
left,right := load_ast(file),load_ast(file);
left,right := load_ast(file),load_ast(file);
Node(type,Void,left,right)
Node(type,Void,left,right)
}</lang>
}</syntaxhighlight>
<lang zkl>ast:=load_ast(File(vm.nthArg(0)));
<syntaxhighlight lang="zkl">ast:=load_ast(File(vm.nthArg(0)));
code:=asm(ast,Data());
code:=asm(ast,Data());
code_finish(code);
code_finish(code);
unasm(code);
unasm(code);
File("code.bin","wb").write(code);
File("code.bin","wb").write(code);
println("Wrote %d bytes to code.bin".fmt(code.len()));</lang>
println("Wrote %d bytes to code.bin".fmt(code.len()));</syntaxhighlight>
File ast.txt is the text at the start of this task.
File ast.txt is the text at the start of this task.
{{out}}
{{out}}

Latest revision as of 15:48, 20 November 2023

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.

Task

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

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

Example - given the simple program (below), stored in a file called while.t, create the list of tokens, using one of the Lexical analyzer solutions
lex < while.t > while.lex
Run one of the Syntax analyzer solutions
parse < while.lex > while.ast
while.ast can be input into the code generator.
The following table shows the input to lex, lex output, the AST produced by the parser, and the generated virtual assembly code.
Run as:  lex < while.t | parse | gen
Input to lex Output from lex, input to parse Output from parse Output from gen, input to VM 
count = 1;
while (count < 10) {
    print("count is: ", count, "\n");
    count = count + 1;
}

    1      1   Identifier      count
    1      7   Op_assign
    1      9   Integer              1
    1     10   Semicolon
    2      1   Keyword_while
    2      7   LeftParen
    2      8   Identifier      count
    2     14   Op_less
    2     16   Integer             10
    2     18   RightParen
    2     20   LeftBrace
    3      5   Keyword_print
    3     10   LeftParen
    3     11   String          "count is: "
    3     23   Comma
    3     25   Identifier      count
    3     30   Comma
    3     32   String          "\n"
    3     36   RightParen
    3     37   Semicolon
    4      5   Identifier      count
    4     11   Op_assign
    4     13   Identifier      count
    4     19   Op_add
    4     21   Integer              1
    4     22   Semicolon
    5      1   RightBrace
    6      1   End_of_input
 
Sequence
Sequence
;
Assign
Identifier    count
Integer       1
While
Less
Identifier    count
Integer       10
Sequence
Sequence
;
Sequence
Sequence
Sequence
;
Prts
String        "count is: "
;
Prti
Identifier    count
;
Prts
String        "\n"
;
Assign
Identifier    count
Add
Identifier    count
Integer       1
 
Datasize: 1 Strings: 2
"count is: "
"\n"
   0 push  1
   5 store [0]
  10 fetch [0]
  15 push  10
  20 lt
  21 jz     (43) 65
  26 push  0
  31 prts
  32 fetch [0]
  37 prti
  38 push  1
  43 prts
  44 fetch [0]
  49 push  1
  54 add
  55 store [0]
  60 jmp    (-51) 10
  65 halt
Input format

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

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

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

def load_ast()
    line = readline()
    # Each line has at least one token
    line_list = tokenize the line, respecting double quotes

    text = line_list[0] # first token is always the node type

    if text == ";"
        return None

    node_type = text # could convert to internal form if desired

    # A line with two tokens is a leaf node
    # Leaf nodes are: Identifier, Integer String
    # The 2nd token is the value
    if len(line_list) > 1
        return make_leaf(node_type, line_list[1])

    left = load_ast()
    right = load_ast()
    return make_node(node_type, left, right)
Output format - refer to the table above
  • The first line is the header: Size of data, and number of constant strings.
    • size of data is the number of 32-bit unique variables used. In this example, one variable, count
    • number of constant strings is just that - how many there are
  • After that, the constant strings
  • Finally, the assembly code
Registers
  • sp: the stack pointer - points to the next top of stack. The stack is a 32-bit integer array.
  • pc: the program counter - points to the current instruction to be performed. The code is an array of bytes.
Data

32-bit integers and strings

Instructions

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

fetch [index]

where index is an index into the data array. 

store [index]

where index is an index into the data array. 

push n

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

jmp (n) addr

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

jz (n) addr

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

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

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

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

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

neg
not

prtc

Print the word at stack top as a character. 

prti

Print the word at stack top as an integer. 

prts

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

halt

Unconditional stop.

Additional examples

Your solution should pass all the test cases above and the additional tests found Here.

Reference

The C and Python versions can be considered reference implementations.

Related Tasks

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. 

# 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

# 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
  ;
# 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  "
  ) ;
# 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;
# label number for label generation #
INT next label number := 0;
# returns the next free label number #
PROC new label = INT: next label number +:= 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 );
# returns a new operand node #
PROC operand node = ( INT op type, value )REF NODE: HEAP NODE := NODE( op type, NIL, NIL, value );

# reports an error and stops #
PROC gen error = ( STRING message )VOID:
     BEGIN
        print( ( message, newline ) );
        stop
     END # gen error # ;

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

# returns a formatted op code for code generation #
PROC operation = ( INT op code )STRING: "            " + op name[ op code ] + "  ";
# defines the specified label #
PROC define label = ( INT label number )VOID: print( ( "lbl_", whole( label number, 0 ), ":", newline ) );
# generates code to load a string value #
PROC gen load string   = ( INT value )VOID:
     BEGIN
        print( ( operation( opushstr ), "  ", strings[ value ], """", newline ) )
     END # push string # ;
# generates code to load a constant value #
PROC gen load constant = ( INT value )VOID: print( ( operation( opush ), "  ", whole( value, 0 ), newline ) );
# generates an operation acting on an address #
PROC gen data op = ( INT op, address )VOID: print( ( operation( op ), "  l_", identifiers[ address ], newline ) );
# generates a nullary operation #
PROC gen op 0    = ( INT op )VOID:          print( ( operation( op ), newline ) );
# generates a "not" instruction sequence #
PROC gen not = VOID:
     BEGIN
        gen load constant( 0 );
        print( ( operation( oeq ), newline ) )
     END # gen not # ;
# 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 # ;
# generates a jump operation #
PROC gen jump = ( INT op, label )VOID: print( ( operation( op ), "  lbl_", whole( label, 0 ), newline ) );
# 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 # ;

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

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

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

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

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

ATS

For ATS2 with a garbage collector. 

(* The Rosetta Code code generator in ATS2. *)

(* Usage: gen [INPUTFILE [OUTPUTFILE]]
   If INPUTFILE or OUTPUTFILE is "-" or missing, then standard input
   or standard output is used, respectively. *)

(* Note: you might wish to add code to catch exceptions and print nice
   messages. *)

(*------------------------------------------------------------------*)

#define ATS_DYNLOADFLAG 0

#include "share/atspre_staload.hats"
staload UN = "prelude/SATS/unsafe.sats"

#define NIL list_vt_nil ()
#define ::  list_vt_cons

%{^
/* alloca(3) is needed for ATS exceptions. */
#include <alloca.h>
%}

exception internal_error of ()
exception bad_ast_node_type of string
exception premature_end_of_input of ()
exception bad_number_field of string
exception missing_identifier_field of ()
exception bad_quoted_string of string

(* Some implementations that are likely missing from the prelude. *)
implement
g0uint2int<sizeknd, llintknd> x =
  $UN.cast x
implement
g0uint2uint<sizeknd, ullintknd> x =
  $UN.cast x
implement
g0uint2int<ullintknd, llintknd> x =
  $UN.cast x

(*------------------------------------------------------------------*)

extern fn {}
skip_characters$skipworthy (c : char) :<> bool

fn {}
skip_characters {n : int}
                {i : nat | i <= n}
                (s : string n,
                 i : size_t i)
    :<> [j : int | i <= j; j <= n]
        size_t j =
  let
    fun
    loop {k : int | i <= k; k <= n}
         .<n - k>.
         (k : size_t k)
        :<> [j : int | k <= j; j <= n]
            size_t j =
      if string_is_atend (s, k) then
        k
      else if ~skip_characters$skipworthy (string_get_at (s, k)) then
        k
      else
        loop (succ k)
  in
    loop i
  end

fn
skip_whitespace {n : int}
                {i : nat | i <= n}
                (s : string n,
                 i : size_t i)
    :<> [j : int | i <= j; j <= n]
        size_t j =
  let
    implement
    skip_characters$skipworthy<> c =
      isspace c
  in
    skip_characters<> (s, i)
  end

fn
skip_nonwhitespace {n : int}
                   {i : nat | i <= n}
                   (s : string n,
                    i : size_t i)
    :<> [j : int | i <= j; j <= n]
        size_t j =
  let
    implement
    skip_characters$skipworthy<> c =
      ~isspace c
  in
    skip_characters<> (s, i)
  end

fn
skip_nonquote {n : int}
              {i : nat | i <= n}
              (s : string n,
               i : size_t i)
    :<> [j : int | i <= j; j <= n]
        size_t j =
  let
    implement
    skip_characters$skipworthy<> c =
      c <> '"'
  in
    skip_characters<> (s, i)
  end

fn
skip_to_end {n : int}
            {i : nat | i <= n}
            (s : string n,
             i : size_t i)
    :<> [j : int | i <= j; j <= n]
        size_t j =
  let
    implement
    skip_characters$skipworthy<> c =
      true
  in
    skip_characters<> (s, i)
  end

(*------------------------------------------------------------------*)

fn
substring_equals {n    : int}
                 {i, j : nat | i <= j; j <= n}
                 (s    : string n,
                  i    : size_t i,
                  j    : size_t j,
                  t    : string)
    :<> bool =
  let
    val m = strlen t
  in
    if j - i <> m then
      false                   (* The substring is the wrong length. *)
    else
      let
        val p_s = ptrcast s
        and p_t = ptrcast t
      in
        0 = $extfcall (int, "strncmp",
                       ptr_add<char> (p_s, i), p_t, m)
      end
  end

(*------------------------------------------------------------------*)

datatype node_type_t =
| NullNode
| 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

#define ARBITRARY_NODE_ARG 1234

datatype ast_node_t =
| ast_node_t_nil
| ast_node_t_nonnil of node_contents_t
where node_contents_t =
  @{
    node_type = node_type_t,
    node_arg = ullint,
    node_left = ast_node_t,
    node_right = ast_node_t
  }

fn
get_node_type {n : int}
              {i : nat | i <= n}
              (s : string n,
               i : size_t i)
    : [j : int | i <= j; j <= n]
      @(node_type_t,
        size_t j) =
  let
    val i_start = skip_whitespace (s, i)
    val i_end = skip_nonwhitespace (s, i_start)

    macdef eq t =
      substring_equals (s, i_start, i_end, ,(t))

    val node_type =
      if eq ";" then
        NullNode
      else if eq "Identifier" then
        Identifier
      else if eq "String" then
        String
      else if eq "Integer" then
        Integer
      else if eq "Sequence" then
        Sequence
      else if eq "If" then
        If
      else if eq "Prtc" then
        Prtc
      else if eq "Prts" then
        Prts
      else if eq "Prti" then
        Prti
      else if eq "While" then
        While
      else if eq "Assign" then
        Assign
      else if eq "Negate" then
        Negate
      else if eq "Not" then
        Not
      else if eq "Multiply" then
        Multiply
      else if eq "Divide" then
        Divide
      else if eq "Mod" then
        Mod
      else if eq "Add" then
        Add
      else if eq "Subtract" then
        Subtract
      else if eq "Less" then
        Less
      else if eq "LessEqual" then
        LessEqual
      else if eq "Greater" then
        Greater
      else if eq "GreaterEqual" then
        GreaterEqual
      else if eq "Equal" then
        Equal
      else if eq "NotEqual" then
        NotEqual
      else if eq "And" then
        And
      else if eq "Or" then
        Or
      else
        let
          val s_bad =
            strnptr2string
              (string_make_substring (s, i_start, i_end - i_start))
        in
          $raise bad_ast_node_type s_bad
        end
  in
    @(node_type, i_end)
  end

fn
get_unsigned {n : int}
             {i : nat | i <= n}
             (s : string n,
              i : size_t i)
    : [j : int | i <= j; j <= n]
      @(ullint,
        size_t j) =
  let
    val i = skip_whitespace (s, i)
    val [j : int] j = skip_nonwhitespace (s, i)
  in
    if j = i then
      $raise bad_number_field ""
    else
      let
        fun
        loop {k : int | i <= k; k <= j}
             (k : size_t k,
              v : ullint)
            : ullint =
          if k = j then
            v
          else
            let
              val c = string_get_at (s, k)
            in
              if ~isdigit c then
                let
                  val s_bad =
                    strnptr2string
                      (string_make_substring (s, i, j - i))
                in
                  $raise bad_number_field s_bad
                end
              else
                let
                  val digit = char2int1 c - char2int1 '0'
                  val () = assertloc (0 <= digit)
                in
                  loop (succ k, (g1i2u 10 * v) + g1i2u digit)
                end
            end
      in
        @(loop (i, g0i2u 0), j)
      end
  end

fn
get_identifier
          {n : int}
          {i : nat | i <= n}
          (s : string n,
           i : size_t i)
    : [j : int | i <= j; j <= n]
      @(string,
        size_t j) =
  let
    val i = skip_whitespace (s, i)
    val j = skip_nonwhitespace (s, i)
  in
    if i = j then
      $raise missing_identifier_field ()
    else
      let
        val ident =
          strnptr2string (string_make_substring (s, i, j - i))
      in
        @(ident, j)
      end
  end

fn
get_quoted_string
          {n : int}
          {i : nat | i <= n}
          (s : string n,
           i : size_t i)
    : [j : int | i <= j; j <= n]
      @(string,
        size_t j) =
  let
    val i = skip_whitespace (s, i)
  in
    if string_is_atend (s, i) then
      $raise bad_quoted_string ""
    else if string_get_at (s, i) <> '"' then
      let
        val j = skip_to_end (s, i)
        val s_bad =
          strnptr2string (string_make_substring (s, i, j - i))
      in
        $raise bad_quoted_string s_bad
      end
    else
      let
        val j = skip_nonquote (s, succ i)
      in
        if string_is_atend (s, j) then
          let
            val s_bad =
              strnptr2string (string_make_substring (s, i, j - i))
          in
            $raise bad_quoted_string s_bad
          end
        else
          let
            val quoted_string =
              strnptr2string
                (string_make_substring (s, i, succ j - i))
          in
            @(quoted_string, succ j)
          end
      end
  end

fn
collect_string
          {n       : int}
          (str     : string,
           strings : &list_vt (string, n) >> list_vt (string, m))
    : #[m : int | m == n || m == n + 1]
       [str_num : nat | str_num <= m]
       size_t str_num =
  (* This implementation uses ‘list_vt’ instead of ‘list’, so
     appending elements to the end of the list will be both efficient
     and safe. It would also have been reasonable to build a ‘list’
     backwards and then make a reversed copy. *)
  let
    fun
    find_or_extend
              {i : nat | i <= n}
              .<n - i>.
              (strings1 : &list_vt (string, n - i)
                            >> list_vt (string, m),
               i        : size_t i)
        : #[m : int | m == n - i || m == n - i + 1]
           [j  : nat | j <= n]
          size_t j =
      case+ strings1 of
      | ~ NIL =>
        let            (* The string is not there. Extend the list. *)
          prval () = prop_verify {i == n} ()
        in
          strings1 := (str :: NIL);
          i
        end
      | @ (head :: tail) =>
        if head = str then
          let                   (* The string is found. *)
            prval () = fold@ strings1
          in
            i
          end
        else
          let                   (* Continue looking. *)
            val j = find_or_extend (tail, succ i)
            prval () = fold@ strings1
          in
            j
          end

    prval () = lemma_list_vt_param strings
    val n = i2sz (length strings)
    and j = find_or_extend (strings, i2sz 0)
  in
    j
  end

fn
load_ast (inpf    : FILEref,
          idents  : &List_vt string >> _,
          strings : &List_vt string >> _)
    : ast_node_t =
  let
    fun
    recurs (idents  : &List_vt string >> _,
            strings : &List_vt string >> _)
        : ast_node_t =
      if fileref_is_eof inpf then
        $raise premature_end_of_input ()
      else
        let
          val s = strptr2string (fileref_get_line_string inpf)
          prval () = lemma_string_param s (* String length >= 0. *)

          val i = i2sz 0
          val @(node_type, i) = get_node_type (s, i)
        in
          case+ node_type of
          | NullNode () => ast_node_t_nil ()
          | Integer () =>
            let
              val @(number, _) = get_unsigned (s, i)
            in
              ast_node_t_nonnil
                @{
                  node_type = node_type,
                  node_arg = number,
                  node_left = ast_node_t_nil,
                  node_right = ast_node_t_nil
                }
            end
          | Identifier () =>
            let
              val @(ident, _) = get_identifier (s, i)
              val arg = collect_string (ident, idents)
            in
              ast_node_t_nonnil
                @{
                  node_type = node_type,
                  node_arg = g0u2u arg,
                  node_left = ast_node_t_nil,
                  node_right = ast_node_t_nil
                }
            end
          | String () =>
            let
              val @(quoted_string, _) = get_quoted_string (s, i)
              val arg = collect_string (quoted_string, strings)
            in
              ast_node_t_nonnil
                @{
                  node_type = node_type,
                  node_arg = g0u2u arg,
                  node_left = ast_node_t_nil,
                  node_right = ast_node_t_nil
                }
            end
          | _ =>
            let
              val node_left = recurs (idents, strings)
              val node_right = recurs (idents, strings)
            in
              ast_node_t_nonnil
                @{
                  node_type = node_type,
                  node_arg = g1i2u ARBITRARY_NODE_ARG,
                  node_left = node_left,
                  node_right = node_right
                }
            end
        end
  in
    recurs (idents, strings)
  end

fn
print_strings {n       : int}
              (outf    : FILEref,
               strings : !list_vt (string, n))
    : void =
  let
    fun
    loop {m : nat}
         .<m>.
         (strings1 : !list_vt (string, m)) :
        void =
      case+ strings1 of
      | NIL => ()
      | head :: tail =>
        begin
          fprintln! (outf, head);
          loop tail
        end

    prval () = lemma_list_vt_param strings
  in
    loop strings
  end

(*------------------------------------------------------------------*)

#define ARBITRARY_INSTRUCTION_ARG 1234
#define ARBITRARY_JUMP_ARG 123456789

typedef instruction_t =
  @{
    address = ullint,
    opcode = string,
    arg = llint
  }

typedef code_t = ref instruction_t

vtypedef pjump_t (p : addr) =
  (instruction_t @ p,
   instruction_t @ p -<lin,prf> void |
   ptr p)
vtypedef pjump_t = [p : addr] pjump_t p

fn
add_instruction (opcode : string,
                 arg    : llint,
                 size   : uint,
                 code   : &List0_vt code_t >> List1_vt code_t,
                 pc     : &ullint >> _)
    : void =
  let
    val instr =
      @{
        address = pc,
        opcode = opcode,
        arg = arg
      }
  in
    code := (ref instr :: code);
    pc := pc + g0u2u size
  end

fn
add_jump (opcode : string,
          code   : &List0_vt code_t >> List1_vt code_t,
          pc     : &ullint >> _)
    : pjump_t =
  let
    val instr =
      @{
        address = pc,
        opcode = opcode,
        arg = g1i2i ARBITRARY_JUMP_ARG
      }
    val ref_instr = ref instr
  in
    code := (ref_instr :: code);
    pc := pc + g0u2u 5U;
    ref_vtakeout ref_instr
  end

fn
fill_jump (pjump   : pjump_t,
           address : ullint)
    : void =
  let
    val @(pf, fpf | p) = pjump
    val instr0 = !p
    val jump_offset : llint =
      let
        val from = succ (instr0.address)
        and to = address
      in
        if from <= to then
          g0u2i (to - from)
        else
          ~g0u2i (from - to)
      end
    val instr1 =
      @{
        address = instr0.address,
        opcode = instr0.opcode,
        arg = jump_offset
      }
    val () = !p := instr1
    prval () = fpf pf
  in
  end

fn
add_filled_jump (opcode  : string,
                 address : ullint,
                 code    : &List0_vt code_t >> List1_vt code_t,
                 pc      : &ullint >> _)
    : void =
  let
    val pjump = add_jump (opcode, code, pc)
  in
    fill_jump (pjump, address)
  end

fn
generate_code (ast : ast_node_t)
    : List_vt code_t =
  let
    fnx
    traverse (ast  : ast_node_t,
              code : &List0_vt code_t >> _,
              pc   : &ullint >> _)
        : void =
      (* Generate the code by consing a list. *)
      case+ ast of
      | ast_node_t_nil () => ()
      | ast_node_t_nonnil contents =>
        begin
          case+ contents.node_type of
          | NullNode () => $raise internal_error ()

          | If () => if_then (contents, code, pc)
          | While () => while_do (contents, code, pc)

          | Sequence () => sequence (contents, code, pc)
          | Assign () => assign (contents, code, pc)

          | Identifier () => immediate ("fetch", contents, code, pc)
          | Integer () => immediate ("push", contents, code, pc)
          | String () => immediate ("push", contents, code, pc)

          | Prtc () => unary_op ("prtc", contents, code, pc)
          | Prti () => unary_op ("prti", contents, code, pc)
          | Prts () => unary_op ("prts", contents, code, pc)
          | Negate () => unary_op ("neg", contents, code, pc)
          | Not () => unary_op ("not", contents, code, pc)

          | Multiply () => binary_op ("mul", contents, code, pc)
          | Divide () => binary_op ("div", contents, code, pc)
          | Mod () => binary_op ("mod", contents, code, pc)
          | Add () => binary_op ("add", contents, code, pc)
          | Subtract () => binary_op ("sub", contents, code, pc)
          | Less () => binary_op ("lt", contents, code, pc)
          | LessEqual () => binary_op ("le", contents, code, pc)
          | Greater () => binary_op ("gt", contents, code, pc)
          | GreaterEqual () => binary_op ("ge", contents, code, pc)
          | Equal () => binary_op ("eq", contents, code, pc)
          | NotEqual () => binary_op ("ne", contents, code, pc)
          | And () => binary_op ("and", contents, code, pc)
          | Or () => binary_op ("or", contents, code, pc)
        end
    and
    if_then (contents : node_contents_t,
             code     : &List0_vt code_t >> _,
             pc       : &ullint >> _)
        : void =
      case- (contents.node_right) of
      | ast_node_t_nonnil contents1 =>
        let
          val condition = (contents.node_left)
          and true_branch = (contents1.node_left)
          and false_branch = (contents1.node_right)

          (* Generate code to evaluate the condition. *)
          val () = traverse (condition, code, pc);

          (* Generate a conditional jump. Where it goes to will be
             filled in later. *)
          val pjump = add_jump ("jz", code, pc)

          (* Generate code for the true branch. *)
          val () = traverse (true_branch, code, pc);
        in
          case+ false_branch of
          | ast_node_t_nil () =>
            begin               (* There is no false branch. *)
              (* Fill in the conditional jump to come here. *)
              fill_jump (pjump, pc)
            end
          | ast_node_t_nonnil _ =>
            let                 (* There is a false branch. *)
              (* Generate an unconditional jump. Where it goes to will
                 be filled in later. *)
              val pjump1 = add_jump ("jmp", code, pc)

              (* Fill in the conditional jump to come here. *)
              val () = fill_jump (pjump, pc)

              (* Generate code for the false branch. *)
              val () = traverse (false_branch, code, pc);

              (* Fill in the unconditional jump to come here. *)
              val () = fill_jump (pjump1, pc)
            in
            end
        end
    and
    while_do (contents : node_contents_t,
              code     : &List0_vt code_t >> _,
              pc       : &ullint >> _)
        : void =
      (* I would prefer to implement ‘while’ by putting the
         conditional jump at the end, and jumping to it to get into
         the loop. However, we need to generate not the code of our
         choice, but the reference result. The reference result has
         the conditional jump at the top. *)
      let
        (* Where to jump from the bottom of the loop. *)
        val loop_top_address = pc
        
        (* Generate code to evaluate the condition. *)
        val () = traverse (contents.node_left, code, pc)

        (* Generate a conditional jump. It will be filled in later to
           go past the end of the loop. *)
        val pjump = add_jump ("jz", code, pc)

        (* Generate code for the loop body. *)
        val () = traverse (contents.node_right, code, pc)

        (* Generate a jump to the top of the loop. *)
        val () = add_filled_jump ("jmp", loop_top_address, code, pc)

        (* Fill in the conditional jump to come here. *)
        val () = fill_jump (pjump, pc)
      in
      end
    and
    sequence (contents : node_contents_t,
              code     : &List0_vt code_t >> _,
              pc       : &ullint >> _)
        : void =
      begin
        traverse (contents.node_left, code, pc);
        traverse (contents.node_right, code, pc)
      end
    and
    assign (contents : node_contents_t,
            code     : &List0_vt code_t >> _,
            pc       : &ullint >> _)
        : void =
      case- contents.node_left of
      | ast_node_t_nonnil ident_contents =>
        let
          val variable_no = ident_contents.node_arg
        in
          traverse (contents.node_right, code, pc);
          add_instruction ("store", g0u2i variable_no, 5U, code, pc)
        end
    and
    immediate (opcode   : string,
               contents : node_contents_t,
               code     : &List0_vt code_t >> _,
               pc       : &ullint >> _)
        : void =
      add_instruction (opcode, g0u2i (contents.node_arg), 5U,
                       code, pc)
    and
    unary_op (opcode   : string,
              contents : node_contents_t,
              code     : &List0_vt code_t >> _,
              pc       : &ullint >> _)
        : void =
      begin
        traverse (contents.node_left, code, pc);
        add_instruction (opcode, g0i2i ARBITRARY_INSTRUCTION_ARG, 1U,
                         code, pc)
      end
    and
    binary_op (opcode   : string,
               contents : node_contents_t,
               code     : &List0_vt code_t >> _,
               pc       : &ullint >> _)
        : void =
      begin
        traverse (contents.node_left, code, pc);
        traverse (contents.node_right, code, pc);
        add_instruction (opcode, g0i2i ARBITRARY_INSTRUCTION_ARG, 1U,
                         code, pc)
      end

    var code : List_vt code_t = NIL
    var pc : ullint = g0i2u 0
  in
    traverse (ast, code, pc);
    add_instruction ("halt", g0i2i ARBITRARY_INSTRUCTION_ARG, 1U,
                     code, pc);

    (* The code is a cons-list, in decreasing-address order, so
       reverse it to put the instructions in increasing-address
       order. *)
    list_vt_reverse code
  end

fn
print_code (outf : FILEref,
            code : !List_vt code_t)
    : void =
  let
    fun
    loop {n : nat}
         .<n>.
         (code : !list_vt (code_t, n))
        : void =
      case+ code of
      | NIL => ()
      | ref_instr :: tail =>
        let
          val @{
                address = address,
                opcode = opcode,
                arg = arg
              } = !ref_instr
        in
          fprint! (outf, address, " ");
          fprint! (outf, opcode);
          if opcode = "push" then
            fprint! (outf, " ", arg)
          else if opcode = "fetch" || opcode = "store" then
            fprint! (outf, " [", arg, "]")
          else if opcode = "jmp" || opcode = "jz" then
            begin
              fprint! (outf, " (", arg, ") ");
              if arg < g1i2i 0 then
                let
                  val offset : ullint = g0i2u (~arg)
                  val () = assertloc (offset <= succ address)
                in
                  fprint! (outf, succ address - offset)
                end
              else
                let
                  val offset : ullint = g0i2u arg
                in
                  fprint! (outf, succ address + offset)
                end
            end;
          fprintln! (outf);
          loop tail
        end

    prval () = lemma_list_vt_param code
  in
    loop code
  end

(*------------------------------------------------------------------*)

fn
main_program (inpf : FILEref,
              outf : FILEref)
    : int =
  let
    var idents : List_vt string = NIL
    var strings : List_vt string = NIL

    val ast = load_ast (inpf, idents, strings)
    val code = generate_code ast

    val () = fprintln! (outf, "Datasize: ", length idents,
                        " Strings: ", length strings)
    val () = print_strings (outf, strings)
    val () = print_code (outf, code)

    val () = free idents
    and () = free strings
    and () = free code
  in
    0
  end

implement
main (argc, argv) =
  let
    val inpfname =
      if 2 <= argc then
        $UN.cast{string} argv[1]
      else
        "-"
    val outfname =
      if 3 <= argc then
        $UN.cast{string} argv[2]
      else
        "-"
    val inpf =
      if (inpfname : string) = "-" then
        stdin_ref
      else
        fileref_open_exn (inpfname, file_mode_r)

    val outf =
      if (outfname : string) = "-" then
        stdout_ref
      else
        fileref_open_exn (outfname, file_mode_w)
  in
    main_program (inpf, outf)
  end

(*------------------------------------------------------------------*)
Output  —  count:
$ patscc -o gen -O3 -DATS_MEMALLOC_GCBDW gen-in-ATS.dats -latslib -lgc && ./gen < count.ast
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. 

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()
}
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 

#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <stdarg.h>
#include <stdint.h>
#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;

#define da_dim(name, type)  type *name = NULL;          \
                            int _qy_ ## name ## _p = 0;  \
                            int _qy_ ## name ## _max = 0

#define da_redim(name)      do {if (_qy_ ## name ## _p >= _qy_ ## name ## _max) \
                                name = realloc(name, (_qy_ ## name ## _max += 32) * sizeof(name[0]));} while (0)

#define da_rewind(name)     _qy_ ## name ## _p = 0

#define da_append(name, x)  do {da_redim(name); name[_qy_ ## name ## _p++] = x;} while (0)
#define da_len(name)        _qy_ ## name ## _p
#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;
}
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. 

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

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

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. 

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

#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

#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
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
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()
}
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: 

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=:{{
   if.#$y do.num=. _ ".y
   else.num=. y end.
   r=. #object
   object=: object,(4#256)#:num
   r
}}

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=: {{echo y throw.}}
getint=: _2147483648+4294967296|2147483648+256#.]

list_code=: {{
  r=.'Datasize: %d Strings: %d\n' sprintf vars;&#strings
  r=.r,;strings,each LF
  pc=. 0
  lim=.<:#object
  while.do.
    op=.(pc{object){::opcodes
    r=.r,'%5d %s'sprintf pc;op
    pc=. pc+1
    i=. getint (lim<.pc+i.4){object
    k=. 0
    select.op
      case.fetch;store do.k=.4[r=.r,' [%d]'sprintf i
      case.push do.k=.4[r=.r,'  %d'sprintf i
      case.jmp;jz do.k=.4[r=.r,'    (%d) %d'sprintf (i-pc);i
      case.halt do.r=.r,LF return.
    end.
    pc=.pc+k
    r=.r,LF
  end.
}}

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

Count example: 

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

Java

Translation of: Python
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());
            }
        }
    }
}

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

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

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]


####################################################################################################
# Code generator.

proc genSimpleInst(gen: var CodeGen; opcode: OpCode) =
  ## Build a simple instruction (no operand).
  gen.instr.add &"{gen.address:>5} {opcode}"

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

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}]"

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

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"

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

proc genPush(gen: var CodeGen; value: int) =
  ## Build a push instruction.
  gen.instr.add &"{gen.address:>5} {opPush:<5} {value}"

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

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

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

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)

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

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

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

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

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)


#———————————————————————————————————————————————————————————————————————————————————————————————————

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

#!/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;

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 

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()
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
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;
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


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

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

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"
            }
          )
      }
  }

}

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

Tested on all examples in Compiler/Sample programs.

Wren

Translation of: Go
Library: Wren-dynamic
Library: Wren-crypto
Library: Wren-fmt
Library: Wren-ioutil
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()
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

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;
    }
}

zkl

Translation of: Python
// 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);
   })
}
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)));
      }
   }
}
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)
}
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()));

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=353127"