(********************************************************************)
(* 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 ([email protected] 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 ([email protected] 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

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


######################################################################
#
# The Rosetta Code code virtual machine in Ratfor 77.
#
# The implementation assumes your FORTRAN compiler supports 1-byte
# INTEGER*1 and 4-byte INTEGER*4. Integer storage will be
# native-endian, achieved via EQUIVALENCE. (GNU Fortran and f2c both
# should work.)
#
#
# How to deal with FORTRAN 77 input is a 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 vm-in-ratfor.r > vm-in-ratfor.f
#    f2c -C -Nc40 vm-in-ratfor.f
#    cc vm-in-ratfor.c -lf2c
#    ./a.out < compiler-tests/primes.vm
#
# With gfortran, a little differently:
#
#    ratfor77 vm-in-ratfor.r > vm-in-ratfor.f
#    gfortran -fcheck=all -std=legacy vm-in-ratfor.f
#    ./a.out < compiler-tests/primes.vm
#
#
# 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(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(STRSZ, 2)           # Size of an entry in the VM strings array.
define(STRI,  1)           # Index of the string within strngs.
define(STRN,  2)           # Length of the string.

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

define(NEWLIN, 10)            # The Unix newline character (ASCII LF).
define(DQUOTE, 34)            # The double quote character.
define(BACKSL, 92)            # The backslash character.

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

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 isalph (c)

  # Is c character code for a letter?

  implicit none

  integer c
  logical isalph

  #
  # The following is correct for ASCII and Unicode, but not for
  # EBCDIC.
  #
  isalph = (ichar ('a') <= c && c <= ichar ('z')) _
             || (ichar ('A') <= c && c <= ichar ('Z'))
end

function isdgt (c)

  # Is c character code for a digit?

  implicit none

  integer c
  logical isdgt

  isdgt = (ichar ('0') <= c && c <= ichar ('9'))
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

function skipal (str, i, imax)

  # Skip past alphabetic characters in a string.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipal

  logical isalph

  logical done

  skipal = i
  done = .false.
  while (!done)
    {
      if (imax <= skipal)
        done = .true.
      else if (!isalph (ichar (str(skipal))))
        done = .true.
      else
        skipal = skipal + 1
    }
end

function skipdg (str, i, imax)

  # Skip past digits in a string.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipdg

  logical isdgt

  logical done

  skipdg = i
  done = .false.
  while (!done)
    {
      if (imax <= skipdg)
        done = .true.
      else if (!isdgt (ichar (str(skipdg))))
        done = .true.
      else
        skipdg = skipdg + 1
    }
end

function skipnd (str, i, imax)

  # Skip past nondigits in a string.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipnd

  logical isdgt

  logical done

  skipnd = i
  done = .false.
  while (!done)
    {
      if (imax <= skipnd)
        done = .true.
      else if (isdgt (ichar (str(skipnd))))
        done = .true.
      else
        skipnd = skipnd + 1
    }
end

function skipd1 (str, i, imax)

  # Skip past digits and '-' in a string.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipd1

  logical isdgt

  logical done

  skipd1 = i
  done = .false.
  while (!done)
    {
      if (imax <= skipd1)
        done = .true.
      else if (!isdgt (ichar (str(skipd1))) && str(skipd1) != '-')
        done = .true.
      else
        skipd1 = skipd1 + 1
    }
end

function skipn1 (str, i, imax)

  # Skip past nondigits in a string, except '-'.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipn1

  logical isdgt

  logical done

  skipn1 = i
  done = .false.
  while (!done)
    {
      if (imax <= skipn1)
        done = .true.
      else if (isdgt (ichar (str(skipn1))) || str(skipn1) == '-')
        done = .true.
      else
        skipn1 = skipn1 + 1
    }
end

function tolowr (c)

  implicit none

  character c
  character tolowr

  integer ic

  # The following is correct for ASCII, and will work with Unicode
  # code points, but is incorrect for EBCDIC.

  ic = ichar (c)
  if (ichar ('A') <= ic && ic <= ichar ('Z'))
    ic = ic - ichar('A') + ichar('a')
  tolowr = char (ic)
end

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

subroutine addstq (strngs, istrng, src, i0, n0, i, n)

  # Add a quoted 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
  logical done

1000 format ('attempt to treat an unquoted string as a quoted string')

  if (src(i0) != char (DQUOTE) || src(i0 + n0 - 1) != char (DQUOTE))
    {
      write (*, 1000)
      stop
    }

  i = istrng

  n = 0
  j = i0 + 1
  done = .false.
  while (j != i0 + n0 - 1)
    if (i == STRNSZ)
      {
        write (*, '(''string pool exhausted'')')
        stop
      }
    else if (src(j) == char (BACKSL))
      {
        if (j == i0 + n0 - 1)
          {
            write (*, '(''incorrectly formed quoted string'')')
            stop
          }
        if (src(j + 1) == 'n')
          strngs(istrng) = char (NEWLIN)
        else if (src(j + 1) == char (BACKSL))
          strngs(istrng) = src(j + 1)
        else
          {
            write (*, '(''unrecognized escape sequence'')')
            stop
          }
        istrng = istrng + 1
        n = n + 1
        j = j + 2
      }
    else
      {
        strngs(istrng) = src(j)
        istrng = istrng + 1
        n = n + 1
        j = j + 1
      }
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 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 an 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

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

function strnat (str, i, n)

  # Convert a string to a non-negative integer.

  implicit none

  character str(*)
  integer i, n
  integer strnat

  integer j

  strnat = 0
  for (j = 0; j < n; j = j + 1)
    strnat = (10 * strnat) + (ichar (str(i + j)) - ichar ('0'))
end

function strint (str, i, n)

  # Convert a string to an integer

  implicit none

  character str(*)
  integer i, n
  integer strint

  integer strnat

  if (str(i) == '-')
    strint = -strnat (str, i + 1, n - 1)
  else
    strint = strnat (str, i, n)
end

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

subroutine put1 (code, i, opcode)

  # Store a 1-byte operation.

  implicit none

  integer*1 code(0 : CODESZ - 1) # Byte code.
  integer i                      # Address to put the code at.
  integer*1 opcode

  if (CODESZ - i < 1)
    {
      write (*, '(''address beyond the size of memory'')')
      stop
    }
  code(i) = opcode
end

subroutine put5 (code, i, opcode, ival)

  # Store a 5-byte operation.

  implicit none

  integer*1 code(0 : CODESZ - 1) # Byte code.
  integer i                      # Address to put the code at.
  integer*1 opcode               #
  integer ival                   # Immediate integer value.

  integer*4 ival32
  integer*1 ival8(4)
  equivalence (ival32, ival8)

  if (CODESZ - i < 5)
    {
      write (*, '(''address beyond the size of memory'')')
      stop
    }
  code(i) = opcode

  # Native-endian storage.
  ival32 = ival
  code(i + 1) = ival8(1)
  code(i + 2) = ival8(2)
  code(i + 3) = ival8(3)
  code(i + 4) = ival8(4)
end

function getimm (code, i)

  # Get an immediate value from the code, at address i.

  implicit none

  integer*1 code(0 : CODESZ - 1) # Byte code.
  integer i                    # Address at which the integer resides.
  integer getimm               # Immediate integer value.

  integer*4 ival32
  integer*1 ival8(4)
  equivalence (ival32, ival8)

  if (i < 0 || CODESZ <= i + 3)
    {
      write (*, '(''code address out of range'')')
      stop
    }

  # Native-endian storage.
  ival8(1) = code(i)
  ival8(2) = code(i + 1)
  ival8(3) = code(i + 2)
  ival8(4) = code(i + 3)
  getimm = ival32
end

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

subroutine rdhead (datsiz, strsiz)

  # Read the header line.

  implicit none

  integer datsiz
  integer strsiz

  integer skipnd
  integer skipdg
  integer strnat

  character line(LINESZ)
  character*20 fmt
  integer i1, j1, i2, j2

  # Read a line of text as an array of characters.
  write (fmt, '(''('', I10, ''A)'')') LINESZ
  read (*, fmt) line

  i1 = skipnd (line, 1, LINESZ + 1)
  j1 = skipdg (line, i1, LINESZ + 1)
  i2 = skipnd (line, j1, LINESZ + 1)
  j2 = skipdg (line, i2, LINESZ + 1)
  if (i1 == j1 || i2 == j2)
    {
      write (*, '(''bad header line'')')
      stop
    }
  datsiz = strnat (line, i1, j1 - i1)
  strsiz = strnat (line, i2, j2 - i2)
end

subroutine rdstrs (strs, strsiz, strngs, istrng)

  implicit none

  integer strs(1:STRSZ, 0 : MAXSTR - 1)
  integer strsiz
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.

  integer trimrt
  integer skipsp

  character line(LINESZ)
  character*20 fmt
  integer j
  integer i, n
  integer i0, n0

  # Read lines of text as an array of characters.
  write (fmt, '(''('', I10, ''A)'')') LINESZ

  for (j = 0; j < strsiz; j = j + 1)
    {
      read (*, fmt) line
      n0 = trimrt (line, LINESZ)
      i0 = skipsp (line, 1, n0 + 1)
      if (i0 == n0 + 1)
        {
          write (*, '(''blank line where a string should be'')')
          stop
        }
      call addstq (strngs, istrng, line, i0, n0 - i0 + 1, i, n)
      strs(STRI, j) = i
      strs(STRN, j) = n
    }
end

function stropc (str, i, n)

  # Convert substring to an opcode.

  implicit none

  character str(*)
  integer i, n
  integer*1 stropc

  stropc = -1
  if (n == 2)
    {
      if (str(i) == 'l')
        {
          if (str(i + 1) == 't')
            stropc = OPLT
          else if (str(i + 1) == 'e')
            stropc = OPLE
        }
      else if (str(i) == 'g')
        {
          if (str(i + 1) == 't')
            stropc = OPGT
          else if (str(i + 1) == 'e')
            stropc = OPGE
        }
      else if (str(i) == 'e' && str(i + 1) == 'q')
        stropc = OPEQ
      else if (str(i) == 'n' && str(i + 1) == 'e')
        stropc = OPNE
      else if (str(i) == 'o' && str(i + 1) == 'r')
        stropc = OPOR
      else if (str(i) == 'j' && str(i + 1) == 'z')
        stropc = OPJZ
    }
  else if (n == 3)
    {
      if (str(i) == 'a')
        {
          if (str(i + 1) == 'd' && str(i + 2) == 'd')
            stropc = OPADD
          else if (str(i + 1) == 'n' && str(i + 2) == 'd')
            stropc = OPAND
        }
      else if (str(i) == 'm')
        {
          if (str(i + 1) == 'o' && str(i + 2) == 'd')
            stropc = OPMOD
          else if (str(i + 1) == 'u' && str(i + 2) == 'l')
            stropc = OPMUL
        }
      else if (str(i) == 'n')
        {
          if (str(i + 1) == 'e' && str(i + 2) == 'g')
            stropc = OPNEG
          else if (str(i + 1) == 'o' && str(i + 2) == 't')
            stropc = OPNOT
        }
      else if (str(i) == 's' && str(i + 1) == 'u' _
                 && str(i + 2) == 'b')
        stropc = OPSUB
      else if (str(i) == 'd' && str(i + 1) == 'i' _
                 && str(i + 2) == 'v')
        stropc = OPDIV
      else if (str(i) == 'j' && str(i + 1) == 'm' _
                 && str(i + 2) == 'p')
        stropc = OPJMP
    }
  else if (n == 4)
    {
      if (str(i) == 'p')
        {
          if (str(i + 1) == 'r' && str(i + 2) == 't')
            {
              if (str(i + 3) == 'c')
                stropc = OPPRTC
              else if (str(i + 3) == 'i')
                stropc = OPPRTI
              else if (str(i + 3) == 's')
                stropc = OPPRTS
            }
          if (str(i + 1) == 'u' && str(i + 2) == 's' _
                && str(i + 3) == 'h')
            stropc = OPPUSH
        }
      else if (str(i) == 'h' && str(i + 1) == 'a' _
                 && str(i + 2) == 'l' && str(i + 3) == 't')
        stropc = OPHALT
    }
  else if (n == 5)
    {
      if (str(i) == 'f' && str(i + 1) == 'e' && str(i + 2) == 't' _
            && str(i + 3) == 'c' && str(i + 4) == 'h')
        stropc = OPFTCH
      if (str(i) == 's' && str(i + 1) == 't' && str(i + 2) == 'o' _
            && str(i + 3) == 'r' && str(i + 4) == 'e')
        stropc = OPSTOR
    }
  if (stropc == -1)
    {
      write (*, '(''unrecognized opcode name'')')
      stop
    }
end

subroutine rdops (code)

  # Read the opcodes and their immediate values.

  implicit none

  integer*1 code(0 : CODESZ - 1) # The byte code.

  integer trimrt
  integer skipsp
  integer skipal
  integer skipdg
  integer skipd1
  integer skipn1
  integer strnat
  integer strint
  integer*1 stropc
  character tolowr

  character line(LINESZ)
  character*20 fmt
  integer stat
  integer n
  integer j
  integer iaddr, jaddr          # Address index and size.
  integer iopnm, jopnm          # Opcode name index and size.
  integer iarg, jarg
  integer addr
  integer arg
  integer*1 opcode

  # Read lines of text as an array of characters.
  write (fmt, '(''('', I10, ''A)'')') LINESZ

  read (*, fmt, iostat = stat) line
  while (stat == 0)
    {
      n = trimrt (line, LINESZ)

      for (j = 1; j <= n; j = j + 1)
        line(j) = tolowr (line(j))

      iaddr = skipsp (line, 1, n + 1)
      jaddr = skipdg (line, iaddr, n + 1)
      addr = strnat (line, iaddr, jaddr - iaddr)

      iopnm = skipsp (line, jaddr, n + 1)
      jopnm = skipal (line, iopnm, n + 1)
      opcode = stropc (line, iopnm, jopnm - iopnm)

      if (opcode == OPPUSH || opcode == OPFTCH || opcode == OPSTOR _
            || opcode == OPJMP || opcode == OPJZ)
        {
          iarg = skipn1 (line, jopnm, n + 1)
          jarg = skipd1 (line, iarg, n + 1)
          arg = strint (line, iarg, jarg - iarg)
          call put5 (code, addr, opcode, arg)
        }
      else
        call put1 (code, addr, opcode)

      read (*, fmt, iostat = stat) line
    }
end

subroutine rdcode (strs, strngs, istrng, code)

  # Read and parse the "assembly" code.

  implicit none

  integer strs(1:STRSZ, 0 : MAXSTR - 1)
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer*1 code(0 : CODESZ - 1) # The byte code.

  integer datsiz
  integer strsiz

  call rdhead (datsiz, strsiz)
  if (MAXVAR < datsiz)
    {
      write (*, '(''too many variables'')')
      stop
    }
  if (MAXSTR < strsiz)
    {
      write (*, '(''too many strings'')')
      stop
    }

  call rdstrs (strs, strsiz, strngs, istrng)
  call rdops (code)
end

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

subroutine stkbin (sp)

  implicit none

  integer sp

  if (sp < 3)
    {
      write (*, '(''stack underflow in binary operation'')')
      stop
    }
end

subroutine stkun (sp)

  implicit none

  integer sp

  if (sp < 2)
    {
      write (*, '(''stack underflow in unary operation'')')
      stop
    }
end

function logl2i (b)

  implicit none

  logical b
  integer logl2i

  if (b)
    logl2i = 1
  else
    logl2i = 0
end

subroutine rncode (strs, strngs, code, outbuf, noutbf)

  # Run the code.

  implicit none

  integer strs(1:STRSZ, 0 : MAXSTR - 1)
  character strngs(STRNSZ)       # String pool.
  integer*1 code(0 : CODESZ - 1) # The byte code.
  character outbuf(OUTLSZ)       # Output line buffer.
  integer noutbf                 # Number of characters in outbuf.

  integer logl2i
  integer getimm
  integer pop

  integer stack(STCKSZ)
  integer data(0 : MAXVAR - 1)
  integer sp                    # Stack pointer.

  integer pc                    # Program counter.
  integer ip                    # Instruction pointer.
  equivalence (pc, ip)          # LOL, use either name. :)

  integer i, n
  integer*1 opcode
  logical done

  sp = 1
  ip = 0

  done = .false.
  while (!done)
    {
      if (ip < 0 || CODESZ <= ip)
        {
          write (*, '(''code address out of range'')')
          stop
        }
      opcode = code(ip)
      ip = ip + 1
      if (opcode == OPADD)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = stack (sp - 1) + stack(sp)
        }
      else if (opcode == OPSUB)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = stack (sp - 1) - stack(sp)
        }
      else if (opcode == OPMUL)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = stack (sp - 1) * stack(sp)
        }
      else if (opcode == OPDIV)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = stack (sp - 1) / stack(sp)
        }
      else if (opcode == OPMOD)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = mod (stack (sp - 1), stack(sp))
        }
      else if (opcode == OPLT)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) < stack(sp))
        }
      else if (opcode == OPGT)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) > stack(sp))
        }
      else if (opcode == OPLE)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) <= stack(sp))
        }
      else if (opcode == OPGE)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) >= stack(sp))
        }
      else if (opcode == OPEQ)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) == stack(sp))
        }
      else if (opcode == OPNE)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) != stack(sp))
        }
      else if (opcode == OPAND)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = _
            logl2i (stack (sp - 1) != 0 && stack(sp) != 0)
        }
      else if (opcode == OPOR)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = _
            logl2i (stack (sp - 1) != 0 || stack(sp) != 0)
        }
      else if (opcode == OPNEG)
        {
          call stkun (sp)
          stack(sp - 1) = -stack(sp - 1)
        }
      else if (opcode == OPNOT)
        {
          call stkun (sp)
          stack(sp - 1) = logl2i (stack(sp - 1) == 0)
        }
      else if (opcode == OPPRTC)
        {
          call wrtchr (outbuf, noutbf, char (pop (stack, sp)))
        }
      else if (opcode == OPPRTI)
        {
          call wrtint (outbuf, noutbf, pop (stack, sp), 0)
        }
      else if (opcode == OPPRTS)
        {
          i = pop (stack, sp)
          if (i < 0 || MAXSTR <= i)
            {
              write (*, '(''string address out of range'')')
              stop
            }
          n = strs(STRN, i)
          i = strs(STRI, i)
          call wrtstr (outbuf, noutbf, strngs, i, n)
        }
      else if (opcode == OPFTCH)
        {
          i = getimm (code, ip)
          ip = ip + 4
          if (i < 0 || MAXVAR <= i)
            {
              write (*, '(''data address out of range'')')
              stop
            }
          call push (stack, sp, data(i))
        }
      else if (opcode == OPSTOR)
        {
          i = getimm (code, ip)
          ip = ip + 4
          if (i < 0 || MAXVAR <= i)
            {
              write (*, '(''data address out of range'')')
              stop
            }
          data(i) = pop (stack, sp)
        }
      else if (opcode == OPPUSH)
        {
          call push (stack, sp, getimm (code, ip))
          ip = ip + 4
        }
      else if (opcode == OPJMP)
        {
          ip = ip + getimm (code, ip)
        }
      else if (opcode == OPJZ)
        {
          if (pop (stack, sp) == 0)
            ip = ip + getimm (code, ip)
          else
            ip = ip + 4
        }
      else
        {
          # Halt on OPHALT or any unrecognized code.
          done = .true.
        }
    }
end

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

program vm

  implicit none

  integer strs(1:STRSZ, 0 : MAXSTR - 1)
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer*1 code(0 : CODESZ - 1) # The byte code.
  character outbuf(OUTLSZ)       # Output line buffer.
  integer noutbf                 # Number of characters in outbuf.

  integer j

  istrng = 1
  noutbf = 0

  for (j = 0; j < CODESZ; j = j + 1)
    code(j) = OPHALT

  call rdcode (strs, strngs, istrng, code)
  call rncode (strs, strngs, code, outbuf, noutbf)

  if (noutbf != 0)
    call flushl (outbuf, noutbf)
end

######################################################################


with javascript_semantics
procedure commatize(string s, sep=",", integer start=1, step=3)
    integer l = length(s)
    for i=start to l do
        if find(s[i],"123456789") then
            for j=i+1 to l+1 do
                if j>l or not find(s[j],"0123456789") then
                    for k=j-1-step to i by -step do
                        s[k+1..k] = sep
                    end for
                    exit
                end if
            end for
            exit
        end if
    end for
    printf(1,"%s\n",{s})
end procedure

commatize("pi=3.14159265358979323846264338327950288419716939937510582097494459231"," ",6,5)
commatize("The author has two Z$100000000000000 Zimbabwe notes (100 trillion).",".")
commatize("\"-in Aus$+1411.8millions\"")
commatize("===US$0017440 millions=== (in 2000 dollars)")
commatize("123.e8000 is pretty big.")
commatize("The land area of the earth is 57268900(29% of the surface) square miles.")
commatize("Ain't no numbers in this here words, nohow, no way, Jose.")
commatize("James was never known as 0000000007")
commatize("Arthur Eddington wrote: I believe there are 15747724136275002577605653961181555468044717914527116709366231425076185631031296 protons in the universe.")
commatize("   $-140000±100 millions.")
commatize("6/9/1946 was a good year for some.")


import re as RegEx

def Commatize( _string, _startPos=0, _periodLen=3, _separator="," ):
	outString = ""
	strPos = 0
	matches = RegEx.findall( "[0-9]*", _string )

	for match in matches[:-1]:
		if not match:
			outString += _string[ strPos ]
			strPos += 1
		else:
			if len(match) > _periodLen:
				leadIn = match[:_startPos]
				periods =  [ match [ i:i + _periodLen ] for i in range ( _startPos, len ( match ), _periodLen ) ]
				outString += leadIn + _separator.join( periods )
			else:
				outString += match

			strPos += len( match )

	return outString

print ( Commatize( "pi=3.14159265358979323846264338327950288419716939937510582097494459231", 0, 5, " " ) )
print ( Commatize( "The author has two Z$100000000000000 Zimbabwe notes (100 trillion).", 0, 3, "." ))
print ( Commatize( "\"-in Aus$+1411.8millions\"" ))
print ( Commatize( "===US$0017440 millions=== (in 2000 dollars)" ))
print ( Commatize( "123.e8000 is pretty big." ))
print ( Commatize( "The land area of the earth is 57268900(29% of the surface) square miles." ))
print ( Commatize( "Ain't no numbers in this here words, nohow, no way, Jose." ))
print ( Commatize( "James was never known as 0000000007" ))
print ( Commatize( "Arthur Eddington wrote: I believe there are 15747724136275002577605653961181555468044717914527116709366231425076185631031296 protons in the universe." ))
print ( Commatize( "␢␢␢$-140000±100 millions." ))
print ( Commatize( "6/9/1946 was a good year for some." ))