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

(********************************************************************)