Compiler/code generator: Difference between revisions
m
→{{header|Wren}}: Minor tidy
m (bugfix (&& as &, part3)) |
m (→{{header|Wren}}: Minor tidy) |
||
| (25 intermediate revisions by 11 users not shown) | |||
Line 4:
into lower level code, either assembly, object, or virtual.
=={{header|Task}}==
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:
|-
| style="vertical-align:top" |
<
while (count < 10) {
print("count is: ", count, "\n");
count = count + 1;
}</
| style="vertical-align:top" |
Line 136:
Loading this data into an internal parse tree should be as simple as:
<
def load_ast()
line = readline()
Line 158:
right = load_ast()
return make_node(node_type, left, right)
</syntaxhighlight>
; Output format - refer to the table above
Line 270:
<br>
As noted in the code, the generated IL is naive - the sample focuses on simplicity.
<
COMMENT
this writes a .NET IL assembler source to standard output.
Line 557:
code header;
gen( code );
code trailer</
{{out}}
<pre>
Line 601:
=={{header|ALGOL W}}==
<
% parse tree nodes %
record node( integer type
Line 966:
genOp0( oHalt );
emitCode
end.</
{{out}}
The While Counter example
Line 991:
60 jmp (-51) 10
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>
=={{header|AWK}}==
Tested with gawk 4.1.1 and mawk 1.3.4.
<syntaxhighlight lang="awk">
function error(msg) {
printf("%s\n", msg)
Line 1,276 ⟶ 2,250:
list_code()
}
</syntaxhighlight>
{{out|case=count}}
<b>
Line 1,304 ⟶ 2,278:
=={{header|C}}==
Tested with gcc 4.81 and later, compiles warning free with -Wall -Wextra
<
#include <stdio.h>
#include <string.h>
Line 1,677 ⟶ 2,651:
return 0;
}</
{{out|case=While counter example}}
Line 1,707 ⟶ 2,681:
Code by Steve Williams. Tested with GnuCOBOL 2.2.
<
identification division.
*> this code is dedicated to the public domain
Line 2,358 ⟶ 3,332:
.
end program showhex.
end program generator.</
{{out|case=Count}}
Line 2,386 ⟶ 3,360:
=={{header|Forth}}==
Tested with Gforth 0.7.3
<
: PEEK BUF @ 0= IF KEY BUF ! THEN BUF @ ;
: GETC PEEK 0 BUF ! ;
Line 2,514 ⟶ 3,488:
DUP 5 < IF CELLS .INT + @ EXECUTE ELSE DROP THEN CR
REPEAT DROP R> DROP ;
GENERATE EMIT BYE</
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}}==
<
mutable struct Asm32
Line 2,681 ⟶ 6,502:
compiletoasm(iob)
</
Datasize: 1 Strings: 2
"count is: "
Line 2,706 ⟶ 6,527:
=={{header|M2000 Interpreter}}==
<syntaxhighlight lang="m2000 interpreter">
Module CodeGenerator (s$){
Function code$(op$) {
Line 2,931 ⟶ 6,752:
Integer 1
}
</syntaxhighlight>
{{out}}
Line 2,957 ⟶ 6,778:
65 halt
</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}}==
Tested with perl v5.26.1
<
use strict; # gen.pl - flatAST to stack machine code
Line 2,999 ⟶ 7,244:
print "Datasize: $namecount Strings: $stringcount\n";
print "$_\n" for sort { $strings{$a} <=> $strings{$b} } keys %strings;
print;</
Passes all tests.
Line 3,005 ⟶ 7,250:
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.
<!--<syntaxhighlight lang="phix">(notonline)-->
<span style="color: #000080;font-style:italic;">--
-- demo\rosetta\Compiler\cgen.e
-- ============================
--
-- 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>
<span style="color: #008080;">include</span> <span style="color: #000000;">parse</span><span style="color: #0000FF;">.</span><span style="color: #000000;">e</span>
<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>
<span style="color: #000000;">strings</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{},</span>
<span style="color: #000000;">stringptrs</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{}</span>
<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>
<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>
<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>
<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>
<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>
<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>
<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: #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>
<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;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">return</span> <span style="color: #000000;">n</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<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>
<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>
<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>
<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>
<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: #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>
<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>
<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>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">return</span> <span style="color: #000000;">n</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<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>
<span style="color: #000080;font-style:italic;">-- note: must be kept precisely in sync with gen_rec!
-- (relentlessly tested via estsize/actsize)</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">size</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">0</span>
<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>
<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>
<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>
<span style="color: #008080;">switch</span> <span style="color: #000000;">n_type</span> <span style="color: #008080;">do</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Sequence</span><span style="color: #0000FF;">:</span>
<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;">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: #008080;">case</span> <span style="color: #000000;">tk_assign</span><span style="color: #0000FF;">:</span>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Integer</span><span style="color: #0000FF;">:</span>
<span style="color: #000000;">size</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">5</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Identifier</span><span style="color: #0000FF;">:</span>
<span style="color: #000000;">size</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">6</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_String</span><span style="color: #0000FF;">:</span>
<span style="color: #000000;">size</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">5</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_while</span><span style="color: #0000FF;">:</span>
<span style="color: #000080;font-style:italic;">-- emit: @@:<condition><topjmp(@f)><body><tailjmp(@b)>@@:</span>
<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>
<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>
<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>
<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>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_lt</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_le</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_ne</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_eq</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_gt</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_ge</span><span style="color: #0000FF;">:</span>
<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;">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;">size</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">10</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_and</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_or</span><span style="color: #0000FF;">:</span>
<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;">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;">size</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">15</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_add</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_sub</span><span style="color: #0000FF;">:</span>
<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;">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;">size</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">4</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_mul</span><span style="color: #0000FF;">:</span>
<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;">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;">size</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">5</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_div</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_mod</span><span style="color: #0000FF;">:</span>
<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;">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;">size</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">6</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_putc</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Printi</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Prints</span><span style="color: #0000FF;">:</span>
<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;">size</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">5</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_if</span><span style="color: #0000FF;">:</span>
<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>
<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>
<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>
<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>
<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>
<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>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_not</span><span style="color: #0000FF;">:</span>
<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;">size</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">9</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_neg</span><span style="color: #0000FF;">:</span>
<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;">size</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">4</span>
<span style="color: #008080;">else</span><span style="color: #0000FF;">:</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;">switch</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">return</span> <span style="color: #000000;">size</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<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>
<span style="color: #000080;font-style:italic;">-- the recursive part of code_gen</span>
<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>
<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>
<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>
<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>
<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>
<span style="color: #008080;">switch</span> <span style="color: #000000;">n_type</span> <span style="color: #008080;">do</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Sequence</span><span style="color: #0000FF;">:</span>
<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>
<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: #008080;">case</span> <span style="color: #000000;">tk_assign</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: #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>
<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;">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>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Integer</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: #000000;">t</span><span style="color: #0000FF;">[</span><span style="color: #000000;">2</span><span style="color: #0000FF;">]</span>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_while</span><span style="color: #0000FF;">:</span>
<span style="color: #000080;font-style:italic;">-- emit: @@:<condition><topjmp(@f)><body><tailjmp(@b)>@@:</span>
<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>
<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>
<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>
<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>
<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>
-- disclaimer: size calcs are not heavily
--
<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>
<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>
<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>
<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>
<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>
<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>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<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;">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>
<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>
<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>
<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>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_lt</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_le</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_gt</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_ge</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_ne</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_eq</span><span style="color: #0000FF;">:</span>
<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>
<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: #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>
<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>
<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>
<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>
<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>
<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>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<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>
<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>
<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>
<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_or</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_and</span><span style="color: #0000FF;">:</span>
<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>
<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: #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>
<span style="color: #000000;">op</span> <span style="color: #0000FF;">*=</span> <span style="color: #000000;">0o010</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;">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>
<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>
<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_add</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_sub</span><span style="color: #0000FF;">:</span>
<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>
<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: #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>
<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>
<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>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_mul</span><span style="color: #0000FF;">:</span>
<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>
<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;">code</span> <span style="color: #0000FF;">&=</span> <span style="color: #0000FF;">{</span>
<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_div</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_mod</span><span style="color: #0000FF;">:</span>
<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>
<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: #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>
<span style="color: #000000;">code</span> <span style="color: #0000FF;">&=</span> <span style="color: #0000FF;">{</span>
<span style="color: #7060A8;">push</span><span style="color: #0000FF;">}</span> <span style="color: #000080;font-style:italic;">-- push eax|edx</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Identifier</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: #000000;">var_idx</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t</span><span style="color: #0000FF;">)</span>
<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>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_putc</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Printi</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Prints</span><span style="color: #0000FF;">:</span>
<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>
<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>
<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>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_String</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: #000000;">string_idx</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t</span><span style="color: #0000FF;">)</span>
<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>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_if</span><span style="color: #0000FF;">:</span>
<span style="color: #000080;font-style:italic;">-- emit: <condition><mainjmp><truepart>[<elsejmp><falsepart>]</span>
<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>
<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>
<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>
<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>
<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>
<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>
<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>
<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>
<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>
<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>
<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>
<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) else/end</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<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>
<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>
<span style="color: #000000;">offset</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">falsesize</span>
<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>
<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>
<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>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<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>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_not</span><span style="color: #0000FF;">:</span>
<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>
<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;">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>
<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>
<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>
<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>
<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;">else</span><span style="color: #0000FF;">:</span>
<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>
<span style="color: #008080;">end</span> <span style="color: #008080;">switch</span>
<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>
<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>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
<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>
<span style="color: #000080;font-style:italic;">--
-- Generates proper machine code.
--
-- Example: i=10; print "\n"; print i; print "\n"
-- Result in vars, strings, chain, code (declared above)
-- where
--
-- code is {
--
--
--
--
--
--
--
-- 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
--
-- 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.
--</span>
<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;">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>
<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
<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>
<span style="color: #008080;">function</span> <span style="color: #000000;">setbuiltins</span><span style="color: #0000FF;">()</span>
<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>
#ilASM{
jmp :setbuiltins
mov esi,1
call :%puts1ediesi -- (edi=raw text, esi=length)
call :%putsint -- (nb limited to +/-9,999,999,999)
mov
mov esi,[edi-12]
call :%puts1ediesi -- (edi=raw text, esi=length)
call
}
<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>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<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>
<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>
<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)
--
-- 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.
--</span>
<span style="color: #004080;">atom</span> <span style="color: #000000;">res</span>
<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>
<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>
<span style="color: #008080;">return</span> <span style="color: #000000;">res</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<span style="color: #008080;">global</span> <span style="color: #008080;">procedure</span> <span style="color: #000000;">fixup</span><span style="color: #0000FF;">()</span>
<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>
<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>
<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:
<!--<syntaxhighlight lang="phix">(notonline)-->
<span style="color: #000080;font-style:italic;">--
-- demo\rosetta\Compiler\cgen.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>
<span style="color: #008080;">include</span> <span style="color: #000000;">cgen</span><span style="color: #0000FF;">.</span><span style="color: #000000;">e</span>
<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>
<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>
<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>
<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>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<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>
<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.</span>
<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>
<span style="color: #004080;">sequence</span> <span style="color: #000000;">octhex</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{}</span>
<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>
<span style="color: #004080;">integer</span> <span style="color: #000000;">len</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">0</span>
<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>
<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>
<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>
<span style="color: #000000;">base</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">1</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span>
<span style="color: #000000;">len</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">oh</span>
<span style="color: #008080;">else</span> <span style="color: #000080;font-style:italic;">-- some octal and some hex</span>
<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>
<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>
<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>
<span style="color: #000000;">base</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">1</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span>
<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: #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>
<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>
<span style="color: #000000;">base</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">1</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span>
<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>
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<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>
<span style="color: #008080;">return</span> <span style="color: #000000;">len</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<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>
<span style="color: #000080;font-style:italic;">--
<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>
<span style="color: #000080;font-style:italic;">-- 8 , 9 , 10 , 11 , 12 , 13 , 14 , 15</span>
<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>
<span style="color: #008080;">procedure</span> <span style="color: #000000;">decode</span><span style="color: #0000FF;">()</span>
<span style="color: #000080;font-style:italic;">-- for a much more complete (and better organised) disassembler, see p2asm.e</span>
<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>
<span style="color: #000000;">opcode</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">xrm</span>
<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>
<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>
<span style="color: #000000;">xrm</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">-</span><span style="color: #000000;">1</span>
<span style="color: #008080;">switch</span> <span style="color: #000000;">opcode</span> <span style="color: #008080;">do</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o150</span><span style="color: #0000FF;">:</span>
<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>
<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>
<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>
<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>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o217</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o377</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: #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>
<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>
<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>
<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>
<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>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o061</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o071</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o205</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: #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>
<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>
<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>
<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>
<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>
<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>
<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>
<span style="color: #008080;">case</span> <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: #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>
<span style="color: #008080;">switch</span> <span style="color: #000000;">xrm</span> <span style="color: #008080;">do</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o224</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o225</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o234</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o235</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o236</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o237</span><span style="color: #0000FF;">:</span>
<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>
<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>
<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>
<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>
<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>
<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>
<span style="color:
<span style="color: #008080;">case</span> <span style="color: #000000;">0o204</span><span style="color: #0000FF;">:</span>
<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>
<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>
<span style="color:
<span style="color: #008080;">end</span> <span style="color: #008080;">switch</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o010</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o040</span><span style="color: #0000FF;">:</span>
<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>
<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>
<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>
<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>
<span style="color:
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o122</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o130</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o131</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o132</span><span style="color: #0000FF;">:</span>
<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>
<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>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o231</span><span style="color: #0000FF;">:</span>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o164</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o353</span><span style="color: #0000FF;">:</span>
<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>
<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>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o351</span><span style="color: #0000FF;">:</span>
<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>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o303</span><span style="color: #0000FF;">:</span>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o350</span><span style="color: #0000FF;">:</span>
<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>
<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>
<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>
<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>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o001</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o041</span><span style="color: #0000FF;">:</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o051</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: #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>
<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>
<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>
<span style="color: #008080;">switch</span> <span style="color: #000000;">xrm</span> <span style="color: #008080;">do</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o004</span><span style="color: #0000FF;">:</span>
<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>
<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>
<span style="color:
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color:
<span style="color: #008080;">end</span> <span style="color: #008080;">switch</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">0o367</span><span style="color: #0000FF;">:</span>
<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>
<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>
<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>
<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>
<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>
<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>
<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>
<span style="color:
<span style="color: #008080;">exit</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;">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>
<span style="color: #0000FF;">?</span><span style="color: #008000;">"incomplete:"</span>
<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>
<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>
<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;">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>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
<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}}
<pre>
Line 3,631 ⟶ 7,880:
=={{header|Python}}==
Tested with Python 2.7 and 3.x
<
import sys, struct, shlex, operator
Line 3,884 ⟶ 8,133:
code_gen(n)
code_finish()
list_code()</
{{out|case=While counter example}}
Line 3,910 ⟶ 8,159:
65 halt</pre>
</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}}==
<
(import (scheme base)
(scheme file)
Line 4,101 ⟶ 10,106:
(generate-code (read-code (cadr (command-line))))
(display "Error: pass an ast filename\n"))
</syntaxhighlight>
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}}==
{{trans|Python}}
<
const WORD_SIZE=4;
Line 4,219 ⟶ 11,113:
code.insert(0,66,text.len(),text);
})
}</
<
all_ops,nthString := all_syms.pump(Dictionary(),"reverse"),-1;
println("Datasize: %d bytes, Strings: %d bytes"
Line 4,254 ⟶ 11,148:
}
}
}</
<
line:=file.readln().strip(); // one or two tokens
if(line[0]==";") return(Void);
Line 4,266 ⟶ 11,160:
left,right := load_ast(file),load_ast(file);
Node(type,Void,left,right)
}</
<
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.
{{out}}
| |||