945 lines
24 KiB
Plaintext
945 lines
24 KiB
Plaintext
(* 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
|
||
|
||
(*------------------------------------------------------------------*)
|