mirror
/
RosettaCodeData
mirror of https://github.com/acmeism/RosettaCodeData.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
RosettaCodeData/Task/Compiler-syntax-analyzer/ATS/compiler-syntax-analyzer.ats

932 lines
26 KiB
Plaintext
Raw Permalink Blame History

(********************************************************************)
(* Usage: parse [INPUTFILE [OUTPUTFILE]]
If INPUTFILE or OUTPUTFILE is "-" or missing, then standard input
or standard output is used, respectively. *)
#include "share/atspre_staload.hats"
staload UN = "prelude/SATS/unsafe.sats"
#define NIL list_nil ()
#define :: list_cons
%{^
/* alloca(3) is needed for ATS exceptions. */
#include <alloca.h>
%}
(********************************************************************)
#define NUM_TOKENS 31
#define TOKEN_ELSE 0
#define TOKEN_IF 1
#define TOKEN_PRINT 2
#define TOKEN_PUTC 3
#define TOKEN_WHILE 4
#define TOKEN_MULTIPLY 5
#define TOKEN_DIVIDE 6
#define TOKEN_MOD 7
#define TOKEN_ADD 8
#define TOKEN_SUBTRACT 9
#define TOKEN_NEGATE 10
#define TOKEN_LESS 11
#define TOKEN_LESSEQUAL 12
#define TOKEN_GREATER 13
#define TOKEN_GREATEREQUAL 14
#define TOKEN_EQUAL 15
#define TOKEN_NOTEQUAL 16
#define TOKEN_NOT 17
#define TOKEN_ASSIGN 18
#define TOKEN_AND 19
#define TOKEN_OR 20
#define TOKEN_LEFTPAREN 21
#define TOKEN_RIGHTPAREN 22
#define TOKEN_LEFTBRACE 23
#define TOKEN_RIGHTBRACE 24
#define TOKEN_SEMICOLON 25
#define TOKEN_COMMA 26
#define TOKEN_IDENTIFIER 27
#define TOKEN_INTEGER 28
#define TOKEN_STRING 29
#define TOKEN_END_OF_INPUT 30
typedef token_t =
[i : int | TOKEN_ELSE <= i; i <= TOKEN_END_OF_INPUT]
int i
typedef tokentuple_t = (token_t, String, ullint, ullint)
fn
token_text (tok : token_t) : String =
case+ tok of
| TOKEN_ELSE => "else"
| TOKEN_IF => "if"
| TOKEN_PRINT => "print"
| TOKEN_PUTC => "putc"
| TOKEN_WHILE => "while"
| TOKEN_MULTIPLY => "*"
| TOKEN_DIVIDE => "/"
| TOKEN_MOD => "%"
| TOKEN_ADD => "+"
| TOKEN_SUBTRACT => "-"
| TOKEN_NEGATE => "-"
| TOKEN_LESS => "<"
| TOKEN_LESSEQUAL => "<="
| TOKEN_GREATER => ">"
| TOKEN_GREATEREQUAL => ">="
| TOKEN_EQUAL => "=="
| TOKEN_NOTEQUAL => "!="
| TOKEN_NOT => "!"
| TOKEN_ASSIGN => "="
| TOKEN_AND => "&&"
| TOKEN_OR => "||"
| TOKEN_LEFTPAREN => "("
| TOKEN_RIGHTPAREN => ")"
| TOKEN_LEFTBRACE => "{"
| TOKEN_RIGHTBRACE => "}"
| TOKEN_SEMICOLON => ";"
| TOKEN_COMMA => ","
| TOKEN_IDENTIFIER => "Ident"
| TOKEN_INTEGER => "Integer literal"
| TOKEN_STRING => "String literal"
| TOKEN_END_OF_INPUT => "EOI"
(********************************************************************)
(* A perfect hash for the lexical token names.
This hash was generated by GNU gperf and then translated to
reasonable ATS by hand. Note, though, that one could have embedded
the generated C code directly and used it. *)
#define MIN_WORD_LENGTH 5
#define MAX_WORD_LENGTH 15
#define MIN_HASH_VALUE 5
#define MAX_HASH_VALUE 64
#define HASH_TABLE_SIZE 65
local
extern castfn u : {n : nat | n < 256} int n -<> uint8 n
in
vtypedef asso_values_vt = @[[n : nat | n < 256] uint8 n][256]
var asso_values =
@[[n : nat | n < 256] uint8 n][256]
(u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 10, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 0, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 0, u 65, u 25,
u 5, u 5, u 0, u 15, u 65, u 0, u 65, u 65, u 10, u 65,
u 30, u 0, u 65, u 5, u 10, u 10, u 0, u 15, u 65, u 65,
u 65, u 5, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65, u 65,
u 65, u 65, u 65, u 65, u 65, u 65)
end
fn
get_asso_value {i : nat | i < 256}
(i : uint i) :<>
[n : nat | n < 256] uint n =
let
extern castfn u8ui : {n : nat} uint8 n -<> uint n
extern castfn mk_asso_values :<>
{p : addr} ptr p -<> (asso_values_vt @ p | ptr p)
val asso_values_tup = mk_asso_values (addr@ asso_values)
macdef asso_values = !(asso_values_tup.1)
val retval = asso_values[i]
val _ = $UN.castvwtp0{void} asso_values_tup
in
u8ui retval
end
fn
hash {n : int | MIN_WORD_LENGTH <= n; n <= MAX_WORD_LENGTH}
(str : string n,
len : size_t n) :<>
[key : nat] uint key =
let
extern castfn uc2ui : {n : nat} uchar n -<> uint n
val c1 = uc2ui (c2uc str[4])
val c2 = uc2ui (c2uc str[pred len])
in
sz2u len + get_asso_value c1 + get_asso_value c2
end
typedef wordlist_vt = @[(String, token_t)][HASH_TABLE_SIZE]
var wordlist =
@[(String, token_t)][HASH_TABLE_SIZE]
(("", 0), ("", 0), ("", 0), ("", 0), ("", 0),
("Comma", 26),
("Op_not", 17),
("", 0), ("", 0), ("", 0),
("Keyword_if", 1),
("Op_mod", 7),
("End_of_input", 30),
("Keyword_print", 2),
("Op_divide", 6),
("RightBrace", 24),
("Op_add", 8),
("Keyword_else", 0),
("Keyword_while", 4),
("Op_negate", 10),
("Identifier", 27),
("Op_notequal", 16),
("Op_less", 11),
("Op_equal", 15),
("LeftBrace", 23),
("Op_or", 20),
("Op_subtract", 9),
("Op_lessequal", 12),
("", 0), ("", 0),
("Op_greater", 13),
("Op_multiply", 5 ),
("Integer", 28),
("", 0), ("", 0),
("Op_greaterequal", 14),
("", 0),
("Keyword_putc", 3),
("", 0),
("LeftParen", 21),
("RightParen", 22),
("Op_and", 19),
("", 0), ("", 0), ("", 0), ("", 0), ("", 0), ("", 0), ("", 0),
("Op_assign", 18),
("", 0),
("String", 29),
("", 0), ("", 0), ("", 0), ("", 0), ("", 0), ("", 0), ("", 0),
("", 0), ("", 0), ("", 0), ("", 0), ("", 0),
("Semicolon", 25))
fn
get_wordlist_entry
{n : nat | n <= MAX_HASH_VALUE}
(key : uint n) :<> (String, token_t) =
let
extern castfn mk_wordlist_tup :<>
{p : addr} ptr p -<> (wordlist_vt @ p | ptr p)
val wordlist_tup = mk_wordlist_tup (addr@ wordlist)
macdef wordlist = !(wordlist_tup.1)
val retval = wordlist[key]
val _ = $UN.castvwtp0{void} wordlist_tup
in
retval
end
fn
string2token_t_opt
{n : int}
(str : string n) :<>
Option token_t =
let
val len = string_length str
in
if len < i2sz MIN_WORD_LENGTH then
None ()
else if i2sz MAX_WORD_LENGTH < len then
None ()
else
let
val key = hash (str, len)
in
if i2u MAX_HASH_VALUE < key then
None ()
else
let
val (s, tok) = get_wordlist_entry (key)
in
if str <> s then
None ()
else
Some tok
end
end
end
(********************************************************************)
exception bad_lex_integer of (String)
exception bad_lex_token_name of (String)
exception bad_string_literal of (String)
extern fun {}
skip_something$pred : char -<> bool
fn {}
skip_something {n : nat}
{i : nat | i <= n}
(s : string n,
n : size_t n,
i : size_t i) :<>
[j : nat | i <= j; j <= n]
size_t j =
let
fun
loop {k : nat | i <= k; k <= n} .<n - k>.
(k : size_t k) :<>
[j : nat | i <= j; j <= n]
size_t j =
if k = n then
k
else if ~(skip_something$pred<> s[k]) then
k
else
loop (succ k)
in
loop i
end
fn
skip_space {n : nat}
{i : nat | i <= n}
(s : string n,
n : size_t n,
i : size_t i) :<>
[j : nat | i <= j; j <= n]
size_t j =
let
implement skip_something$pred<> (c) = isspace c
in
skip_something (s, n, i)
end
fn
skip_nonspace {n : nat}
{i : nat | i <= n}
(s : string n,
n : size_t n,
i : size_t i) :<>
[j : nat | i <= j; j <= n]
size_t j =
let
implement skip_something$pred<> (c) = ~isspace c
in
skip_something (s, n, i)
end
fn
skip_nonquote {n : nat}
{i : nat | i <= n}
(s : string n,
n : size_t n,
i : size_t i) :<>
[j : nat | i <= j; j <= n]
size_t j =
let
implement skip_something$pred<> (c) = c <> '"'
in
skip_something (s, n, i)
end
fn
skip_string_literal
{n : nat}
{i : nat | i <= n}
(s : string n,
n : size_t n,
i : size_t i) :<>
[j : nat | i <= j; j <= n]
size_t j =
if i = n then
i
else if s[i] <> '"' then
i
else
let
val j = skip_nonquote (s, n, succ i)
in
if j = n then
i
else
succ j
end
fn
get_substr {n, i, j : nat | i <= j; j <= n}
(s : string n,
i : size_t i,
j : size_t j) :
[m : int | m == j - i] string m =
let
val s = string_make_substring (s, i, j - i)
in
strnptr2string s
end
fn
string2ullint
{n : nat}
(s : string n) : ullint =
let
val n = string_length s
in
if n = i2sz 0 then
$raise bad_lex_integer ("")
else
let
extern castfn u2ull : uint -<> ullint
fun
evaluate {k : nat | k <= n} .<n - k>.
(k : size_t k,
v : ullint) : ullint =
if k = n then
v
else if ~isdigit s[k] then
$raise bad_lex_integer (s)
else
let
val d = char2ui s[k] - char2ui '0'
in
evaluate (succ k, (10ULL * v) + u2ull d)
end
in
evaluate (i2sz 0, 0ULL)
end
end
fn
string2token {n : int}
(str : string n) : token_t =
case+ string2token_t_opt str of
| None () => $raise bad_lex_token_name (str)
| Some tok => tok
fn
read_lex_file (inpf : FILEref) : List0 tokentuple_t =
(* Convert the output of "lex" to a list of tokens. *)
(* This routine could stand to do more validation of the input. *)
let
fun
loop (lst : List0 tokentuple_t) : List0 tokentuple_t =
if fileref_is_eof inpf then
lst
else
let
val s = strptr2string (fileref_get_line_string inpf)
val n = string_length s
prval _ = lemma_g1uint_param n
val i0_line_no = skip_space (s, n, i2sz 0)
in
if i0_line_no = n then
(* Skip any blank lines, including end of file. *)
loop lst
else
let
val i1_line_no = skip_nonspace (s, n, i0_line_no)
val s_line_no = get_substr (s, i0_line_no, i1_line_no)
val line_no = string2ullint s_line_no
val i0_column_no = skip_space (s, n, i1_line_no)
val i1_column_no = skip_nonspace (s, n, i0_column_no)
val s_column_no = get_substr (s, i0_column_no,
i1_column_no)
val column_no = string2ullint s_column_no
val i0_tokname = skip_space (s, n, i1_column_no)
val i1_tokname = skip_nonspace (s, n, i0_tokname)
val tokname = get_substr (s, i0_tokname, i1_tokname)
val tok = string2token tokname
in
case+ tok of
| TOKEN_INTEGER =>
let
val i0 = skip_space (s, n, i1_tokname)
val i1 = skip_nonspace (s, n, i0)
val arg = get_substr (s, i0, i1)
val toktup = (tok, arg, line_no, column_no)
in
loop (toktup :: lst)
end
| TOKEN_IDENTIFIER =>
let
val i0 = skip_space (s, n, i1_tokname)
val i1 = skip_nonspace (s, n, i0)
val arg = get_substr (s, i0, i1)
val toktup = (tok, arg, line_no, column_no)
in
loop (toktup :: lst)
end
| TOKEN_STRING =>
let
val i0 = skip_space (s, n, i1_tokname)
val i1 = skip_string_literal (s, n, i0)
val arg = get_substr (s, i0, i1)
val toktup = (tok, arg, line_no, column_no)
in
loop (toktup :: lst)
end
| _ =>
let
val toktup = (tok, "", line_no, column_no)
in
loop (toktup :: lst)
end
end
end
in
list_vt2t (list_reverse (loop NIL))
end
(********************************************************************)
exception truncated_lexical of ()
exception unexpected_token of (tokentuple_t, token_t)
exception unexpected_primary of (tokentuple_t)
exception unterminated_statement_block of (ullint, ullint)
exception expected_a_statement of (tokentuple_t)
datatype node_t =
| node_t_nil of ()
| node_t_leaf of (String, String)
| node_t_cons of (String, node_t, node_t)
fn
right_assoc (tok : token_t) : bool =
(* None of the currently supported operators is right
associative. *)
false
fn
binary_op (tok : token_t) : bool =
case+ tok of
| TOKEN_ADD => true
| TOKEN_SUBTRACT => true
| TOKEN_MULTIPLY => true
| TOKEN_DIVIDE => true
| TOKEN_MOD => true
| TOKEN_LESS => true
| TOKEN_LESSEQUAL => true
| TOKEN_GREATER => true
| TOKEN_GREATEREQUAL => true
| TOKEN_EQUAL => true
| TOKEN_NOTEQUAL => true
| TOKEN_AND => true
| TOKEN_OR => true
| _ => false
fn
precedence (tok : token_t) : int =
case+ tok of
| TOKEN_MULTIPLY => 13
| TOKEN_DIVIDE => 13
| TOKEN_MOD => 13
| TOKEN_ADD => 12
| TOKEN_SUBTRACT => 12
| TOKEN_NEGATE => 14
| TOKEN_NOT => 14
| TOKEN_LESS => 10
| TOKEN_LESSEQUAL => 10
| TOKEN_GREATER => 10
| TOKEN_GREATEREQUAL => 10
| TOKEN_EQUAL => 9
| TOKEN_NOTEQUAL => 9
| TOKEN_AND => 5
| TOKEN_OR => 4
| _ => ~1
fn
opname (tok : token_t) : String =
case- tok of
| TOKEN_MULTIPLY => "Multiply"
| TOKEN_DIVIDE => "Divide"
| TOKEN_MOD => "Mod"
| TOKEN_ADD => "Add"
| TOKEN_SUBTRACT => "Subtract"
| TOKEN_NEGATE => "Negate"
| TOKEN_NOT => "Not"
| TOKEN_LESS => "Less"
| TOKEN_LESSEQUAL => "LessEqual"
| TOKEN_GREATER => "Greater"
| TOKEN_GREATEREQUAL => "GreaterEqual"
| TOKEN_EQUAL => "Equal"
| TOKEN_NOTEQUAL => "NotEqual"
| TOKEN_AND => "And"
| TOKEN_OR => "Or"
fn
parse (lex : List0 tokentuple_t) : node_t =
let
typedef toktups_t (n : int) = list (tokentuple_t, n)
typedef toktups_t = [n : nat] toktups_t n
fn
expect (expected : token_t,
lex : toktups_t) : toktups_t =
case+ lex of
| NIL => $raise truncated_lexical ()
| toktup :: tail =>
if toktup.0 = expected then
tail
else
$raise unexpected_token (toktup, expected)
fn
peek {n : int} (lex : toktups_t n) : [1 <= n] token_t =
case+ lex of
| NIL => $raise truncated_lexical ()
| (tok, _, _, _) :: _ => tok
fun
stmt (lex : toktups_t) : (node_t, toktups_t) =
case+ lex of
| NIL => $raise truncated_lexical ()
| (TOKEN_IF, _, _, _) :: lex =>
let
val (e, lex) = paren_expr lex
val (s, lex) = stmt lex
in
case+ lex of
| (TOKEN_ELSE, _, _, _) :: lex =>
let
val (t, lex) = stmt lex
in
(node_t_cons ("If", e, node_t_cons ("If", s, t)), lex)
end
| _ =>
let
(* There is no 'else' clause. *)
val t = node_t_nil ()
in
(node_t_cons ("If", e, node_t_cons ("If", s, t)), lex)
end
end
| (TOKEN_PUTC, _, _, _) :: lex =>
let
val (subtree, lex) = paren_expr lex
val subtree = node_t_cons ("Prtc", subtree, node_t_nil ())
val lex = expect (TOKEN_SEMICOLON, lex)
in
(subtree, lex)
end
| (TOKEN_PRINT, _, _, _) :: lex =>
let
val lex = expect (TOKEN_LEFTPAREN, lex)
fun
loop_over_args (subtree : node_t,
lex : toktups_t) : (node_t, toktups_t) =
case+ lex of
| (TOKEN_STRING, arg, _, _) ::
(TOKEN_COMMA, _, _, _) :: lex =>
let
val leaf = node_t_leaf ("String", arg)
val e = node_t_cons ("Prts", leaf, node_t_nil ())
in
loop_over_args
(node_t_cons ("Sequence", subtree, e), lex)
end
| (TOKEN_STRING, arg, _, _) :: lex =>
let
val lex = expect (TOKEN_RIGHTPAREN, lex)
val lex = expect (TOKEN_SEMICOLON, lex)
val leaf = node_t_leaf ("String", arg)
val e = node_t_cons ("Prts", leaf, node_t_nil ())
in
(node_t_cons ("Sequence", subtree, e), lex)
end
| _ :: _ =>
let
val (x, lex) = expr (0, lex)
val e = node_t_cons ("Prti", x, node_t_nil ())
val subtree = node_t_cons ("Sequence", subtree, e)
in
case+ peek lex of
| TOKEN_COMMA =>
let
val lex = expect (TOKEN_COMMA, lex)
in
loop_over_args (subtree, lex)
end
| _ =>
let
val lex = expect (TOKEN_RIGHTPAREN, lex)
val lex = expect (TOKEN_SEMICOLON, lex)
in
(subtree, lex)
end
end
| NIL => $raise truncated_lexical ()
in
loop_over_args (node_t_nil (), lex)
end
| (TOKEN_SEMICOLON, _, _, _) :: lex => (node_t_nil (), lex)
| (TOKEN_IDENTIFIER, arg, _, _) :: lex =>
let
val v = node_t_leaf ("Identifier", arg)
val lex = expect (TOKEN_ASSIGN, lex)
val (subtree, lex) = expr (0, lex)
val t = node_t_cons ("Assign", v, subtree)
val lex = expect (TOKEN_SEMICOLON, lex)
in
(t, lex)
end
| (TOKEN_WHILE, _, _, _) :: lex =>
let
val (e, lex) = paren_expr lex
val (t, lex) = stmt lex
in
(node_t_cons ("While", e, t), lex)
end
| (TOKEN_LEFTBRACE, _, _, _) :: lex =>
let
fun
loop_over_stmts (subtree : node_t,
lex : toktups_t) :
(node_t, toktups_t) =
case+ lex of
| (TOKEN_RIGHTBRACE, _, _, _) :: lex => (subtree, lex)
| (TOKEN_END_OF_INPUT, _, line_no, column_no) :: _ =>
$raise unterminated_statement_block (line_no, column_no)
| _ =>
let
val (e, lex) = stmt lex
in
loop_over_stmts
(node_t_cons ("Sequence", subtree, e), lex)
end
in
loop_over_stmts (node_t_nil (), lex)
end
| (TOKEN_END_OF_INPUT, _, _, _) :: lex => (node_t_nil (), lex)
| toktup :: _ => $raise expected_a_statement (toktup)
and
expr (prec : int,
lex : toktups_t) : (node_t, toktups_t) =
case+ lex of
| (TOKEN_LEFTPAREN, _, _, _) :: _ =>
(* '(' expr ')' *)
let
val (subtree, lex) = paren_expr lex
in
prec_climb (prec, subtree, lex)
end
| (TOKEN_ADD, _, _, _) :: lex =>
(* '+' expr *)
let
val (subtree, lex) = expr (precedence TOKEN_ADD, lex)
in
prec_climb (prec, subtree, lex)
end
| (TOKEN_SUBTRACT, _, _, _) :: lex =>
(* '-' expr *)
let
val (subtree, lex) = expr (precedence TOKEN_NEGATE, lex)
val subtree = node_t_cons ("Negate", subtree, node_t_nil ())
in
prec_climb (prec, subtree, lex)
end
| (TOKEN_NOT, _, _, _) :: lex =>
(* '!' expr *)
let
val (subtree, lex) = expr (precedence TOKEN_NOT, lex)
val subtree = node_t_cons ("Not", subtree, node_t_nil ())
in
prec_climb (prec, subtree, lex)
end
| (TOKEN_IDENTIFIER, arg, _, _) :: lex =>
let
val leaf = node_t_leaf ("Identifier", arg)
in
prec_climb (prec, leaf, lex)
end
| (TOKEN_INTEGER, arg, _, _) :: lex =>
let
val leaf = node_t_leaf ("Integer", arg)
in
prec_climb (prec, leaf, lex)
end
| toktup :: lex =>
$raise unexpected_primary (toktup)
| NIL =>
$raise truncated_lexical ()
and
prec_climb (prec : int,
subtree : node_t,
lex : toktups_t) : (node_t, toktups_t) =
case+ peek lex of
| tokval =>
if ~binary_op tokval then
(subtree, lex)
else if precedence tokval < prec then
(subtree, lex)
else
case+ lex of
| toktup :: lex =>
let
val q =
if right_assoc (toktup.0) then
precedence tokval
else
succ (precedence tokval)
val (e, lex) = expr (q, lex)
val subtree1 =
node_t_cons (opname (toktup.0), subtree, e)
in
prec_climb (prec, subtree1, lex)
end
and
paren_expr (lex : toktups_t) : (node_t, toktups_t) =
(* '(' expr ')' *)
let
val lex = expect (TOKEN_LEFTPAREN, lex)
val (subtree, lex) = expr (0, lex)
val lex = expect (TOKEN_RIGHTPAREN, lex)
in
(subtree, lex)
end
fun
main_loop (subtree : node_t,
lex : toktups_t) : node_t =
case+ peek lex of
| TOKEN_END_OF_INPUT => subtree
| _ =>
let
val (x, lex) = stmt lex
in
main_loop (node_t_cons ("Sequence", subtree, x), lex)
end
in
main_loop (node_t_nil (), lex)
end
fn
print_ast (outf : FILEref,
ast : node_t) : void =
let
fun
traverse (ast : node_t) : void =
case+ ast of
| node_t_nil () => fprintln! (outf, ";")
| node_t_leaf (str, arg) => fprintln! (outf, str, " ", arg)
| node_t_cons (str, left, right) =>
begin
fprintln! (outf, str);
traverse left;
traverse right
end
in
traverse ast
end
(********************************************************************)
fn
main_program (inpf : FILEref,
outf : FILEref) : int =
let
val toklst = read_lex_file inpf
val ast = parse toklst
val () = print_ast (outf, ast)
in
0
end
fn
error_start (line_no : ullint,
column_no : ullint) : void =
print! ("(", line_no, ", ", column_no, ") error: ")
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
"-"
in
try
let
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
with
| ~ unexpected_primary @(tok, _, line_no, column_no) =>
begin
error_start (line_no, column_no);
println! ("Expecting a primary, found: ", token_text tok);
1
end
| ~ unexpected_token (@(tok, _, line_no, column_no), expected) =>
begin
error_start (line_no, column_no);
println! ("Expecting '", token_text expected,
"', found '", token_text tok, "'");
1
end
| ~ expected_a_statement @(tok, _, line_no, column_no) =>
begin
error_start (line_no, column_no);
println! ("expecting start of statement, found '",
token_text tok, "'");
1
end
| ~ unterminated_statement_block (line_no, column_no) =>
begin
error_start (line_no, column_no);
println! ("unterminated statement block");
1
end
| ~ truncated_lexical () =>
begin
println! ("truncated input token stream");
2
end
| ~ bad_lex_integer (s) =>
begin
println! ("bad integer literal in the token stream: '",
s, "'");
2
end
| ~ bad_string_literal (s) =>
begin
println! ("bad string literal in the token stream: '",
s, "'");
2
end
| ~ bad_lex_token_name (s) =>
begin
println! ("bad token name in the token stream: '",
s, "'");
2
end
end
(********************************************************************)
Reference in New Issue View Git Blame Copy Permalink