% -*- mercury -*-
%
% Compile with maybe something like:
%   mmc -O4 --intermod-opt -E --make --warn-non-tail-recursion self-and-mutual lex
%

:- module lex.

:- interface.
:- import_module io.
:- pred main(io::di, io::uo) is det.

:- implementation.
:- import_module char.
:- import_module exception.
:- import_module int.
:- import_module list.
:- import_module stack.
:- import_module string.

:- type token_t
   ---> token_ELSE
   ;    token_IF
   ;    token_PRINT
   ;    token_PUTC
   ;    token_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
   ;    token_INTEGER
   ;    token_STRING
   ;    token_END_OF_INPUT.

:- type ch_t                 % The type of a fetched character.
   ---> {int,                % A character or `eof', stored as an int.
         int,                % The line number.
         int}.               % The column number.

:- type inp_t            % The `inputter' type. Fetches one character.
   ---> inp_t(inpf :: text_input_stream,
              line_no :: int,
              column_no :: int,
              pushback :: stack(ch_t)).

:- type toktup_t      % The type of a scanned token with its argument.
   ---> {token_t,     % The token kind.
         string,      % An argument. (May or may not be meaningful.)
         int,         % The starting line number.
         int}.        % The starting column number.

main(!IO) :-
    command_line_arguments(Args, !IO),
    (
        if (Args = [])
        then (InpF_filename = "-",
              OutF_filename = "-",
              main_program(InpF_filename, OutF_filename, !IO))
        else if (Args = [F1])
        then (InpF_filename = F1,
              OutF_filename = "-",
              main_program(InpF_filename, OutF_filename, !IO))
        else if (Args = [F1, F2])
        then (InpF_filename = F1,
              OutF_filename = F2,
              main_program(InpF_filename, OutF_filename, !IO))
        else usage_error(!IO)
    ).

:- pred main_program(string::in, string::in, io::di, io::uo) is det.
main_program(InpF_filename, OutF_filename, !IO) :-
    open_InpF(InpF, InpF_filename, !IO),
    open_OutF(OutF, OutF_filename, !IO),
    init(InpF, Inp0),
    scan_text(OutF, Inp0, _, !IO).

:- pred open_InpF(text_input_stream::out, string::in,
                  io::di, io::uo) is det.
open_InpF(InpF, InpF_filename, !IO) :-
    if (InpF_filename = "-")
    then (InpF = io.stdin_stream)
    else
    (
        open_input(InpF_filename, InpF_result, !IO),
        (
            if (InpF_result = ok(F))
            then (InpF = F)
            else throw("Error: cannot open " ++ InpF_filename ++
                       " for input")
        )
    ).

:- pred open_OutF(text_output_stream::out, string::in,
                  io::di, io::uo) is det.
open_OutF(OutF, OutF_filename, !IO) :-
    if (OutF_filename = "-")
    then (OutF = io.stdout_stream)
    else
    (
        open_output(OutF_filename, OutF_result, !IO),
        (
            if (OutF_result = ok(F))
            then (OutF = F)
            else throw("Error: cannot open " ++ OutF_filename ++
                       " for output")
        )
    ).

:- pred usage_error(io::di, io::uo) is det.
usage_error(!IO) :-
    progname("lex", ProgName, !IO),
    (io.format("Usage: %s [INPUT_FILE [OUTPUT_FILE]]\n",
               [s(ProgName)], !IO)),
    (io.write_string("If INPUT_FILE is \"-\" or not present then standard input is used.\n",
                     !IO)),
    (io.write_string("If OUTPUT_FILE is \"-\" or not present then standard output is used.\n",
                     !IO)),
    set_exit_status(1, !IO).

:- pred scan_text(text_output_stream::in, inp_t::in, inp_t::out,
                  io::di, io::uo) is det.
scan_text(OutF, !Inp, !IO) :-
    get_next_token(TokTup, !Inp, !IO),
    print_token(TokTup, OutF, !IO),
    {Tok, _, _, _} = TokTup,
    (
        if (Tok = token_END_OF_INPUT)
        then true
        else scan_text(OutF, !Inp, !IO)
    ).

:- pred print_token(toktup_t::in, text_output_stream::in,
                    io::di, io::uo) is det.
print_token(TokTup, OutF, !IO) :-
    {Tok, Arg, Line_no, Column_no} = TokTup,
    token_name(Tok) = TokName,
    (io.format(OutF, "%5d %5d  %s",
               [i(Line_no), i(Column_no), s(TokName)],
               !IO)),
    (
        if (Tok = token_IDENTIFIER)
        then (io.format(OutF, "     %s", [s(Arg)], !IO))
        else if (Tok = token_INTEGER)
        then (io.format(OutF, "        %s", [s(Arg)], !IO))
        else if (Tok = token_STRING)
        then (io.format(OutF, "         %s", [s(Arg)], !IO))
        else true
    ),
    (io.format(OutF, "\n", [], !IO)).

:- func token_name(token_t) = string is det.
:- pred token_name(token_t::in, string::out) is det.
token_name(Tok) = Str :- token_name(Tok, Str).
token_name(token_ELSE, "Keyword_else").
token_name(token_IF, "Keyword_if").
token_name(token_PRINT, "Keyword_print").
token_name(token_PUTC, "Keyword_putc").
token_name(token_WHILE, "Keyword_while").
token_name(token_MULTIPLY, "Op_multiply").
token_name(token_DIVIDE, "Op_divide").
token_name(token_MOD, "Op_mod").
token_name(token_ADD, "Op_add").
token_name(token_SUBTRACT, "Op_subtract").
token_name(token_NEGATE, "Op_negate").
token_name(token_LESS, "Op_less").
token_name(token_LESSEQUAL, "Op_lessequal").
token_name(token_GREATER, "Op_greater").
token_name(token_GREATEREQUAL, "Op_greaterequal").
token_name(token_EQUAL, "Op_equal").
token_name(token_NOTEQUAL, "Op_notequal").
token_name(token_NOT, "Op_not").
token_name(token_ASSIGN, "Op_assign").
token_name(token_AND, "Op_and").
token_name(token_OR, "Op_or").
token_name(token_LEFTPAREN, "LeftParen").
token_name(token_RIGHTPAREN, "RightParen").
token_name(token_LEFTBRACE, "LeftBrace").
token_name(token_RIGHTBRACE, "RightBrace").
token_name(token_SEMICOLON, "Semicolon").
token_name(token_COMMA, "Comma").
token_name(token_IDENTIFIER, "Identifier").
token_name(token_INTEGER, "Integer").
token_name(token_STRING, "String").
token_name(token_END_OF_INPUT, "End_of_input").

:- pred get_next_token(toktup_t::out, inp_t::in, inp_t::out,
                       io::di, io::uo) is det.
get_next_token(TokTup, !Inp, !IO) :-
    skip_spaces_and_comments(!Inp, !IO),
    get_ch(Ch, !Inp, !IO),
    {IChar, Line_no, Column_no} = Ch,
    LN = Line_no,
    CN = Column_no,
    (
        if (IChar = eof)
        then
        (
            TokTup = {token_END_OF_INPUT, "", LN, CN}
        )
        else
        (
            Char = det_from_int(IChar),
            (
                if (Char = (','))
                then (TokTup = {token_COMMA, ",", LN, CN})
                else if (Char = (';'))
                then (TokTup = {token_SEMICOLON, ";", LN, CN})
                else if (Char = ('('))
                then (TokTup = {token_LEFTPAREN, "(", LN, CN})
                else if (Char = (')'))
                then (TokTup = {token_RIGHTPAREN, ")", LN, CN})
                else if (Char = ('{'))
                then (TokTup = {token_LEFTBRACE, "{", LN, CN})
                else if (Char = ('}'))
                then (TokTup = {token_RIGHTBRACE, "}", LN, CN})
                else if (Char = ('*'))
                then (TokTup = {token_MULTIPLY, "*", LN, CN})
                else if (Char = ('/'))
                then (TokTup = {token_DIVIDE, "/", LN, CN})
                else if (Char = ('%'))
                then (TokTup = {token_MOD, "%", LN, CN})
                else if (Char = ('+'))
                then (TokTup = {token_ADD, "+", LN, CN})
                else if (Char = ('-'))
                then (TokTup = {token_SUBTRACT, "-", LN, CN})
                else if (Char = ('<'))
                then
                (
                    get_ch(Ch1, !Inp, !IO),
                    Ch1 = {IChar1, _, _},
                    (
                        if (IChar1 = to_int('='))
                        then
                        (
                            TokTup = {token_LESSEQUAL, "<=", LN, CN}
                        )
                        else
                        (
                            push_back(Ch1, !Inp),
                            TokTup = {token_LESS, "<", LN, CN}
                        )
                    )
                )
                else if (Char = ('>'))
                then
                (
                    get_ch(Ch1, !Inp, !IO),
                    Ch1 = {IChar1, _, _},
                    (
                        if (IChar1 = to_int('='))
                        then
                        (
                            TokTup = {token_GREATEREQUAL, ">=", LN, CN}
                        )
                        else
                        (
                            push_back(Ch1, !Inp),
                            TokTup = {token_GREATER, ">", LN, CN}
                        )
                    )
                )
                else if (Char = ('='))
                then
                (
                    get_ch(Ch1, !Inp, !IO),
                    Ch1 = {IChar1, _, _},
                    (
                        if (IChar1 = to_int('='))
                        then
                        (
                            TokTup = {token_EQUAL, "==", LN, CN}
                        )
                        else
                        (
                            push_back(Ch1, !Inp),
                            TokTup = {token_ASSIGN, "=", LN, CN}
                        )
                    )
                )
                else if (Char = ('!'))
                then
                (
                    get_ch(Ch1, !Inp, !IO),
                    Ch1 = {IChar1, _, _},
                    (
                        if (IChar1 = to_int('='))
                        then
                        (
                            TokTup = {token_NOTEQUAL, "!=", LN, CN}
                        )
                        else
                        (
                            push_back(Ch1, !Inp),
                            TokTup = {token_NOT, "!", LN, CN}
                        )
                    )
                )
                else if (Char = ('&'))
                then
                (
                    get_ch(Ch1, !Inp, !IO),
                    Ch1 = {IChar1, _, _},
                    (
                        if (IChar1 = to_int('&'))
                        then
                        (
                            TokTup = {token_AND, "&&", LN, CN}
                        )
                        else throw("Error: unexpected character '" ++
                                   from_char(Char) ++ "' at " ++
                                   from_int(LN) ++ ":" ++
                                   from_int(CN))
                    )
                )
                else if (Char = ('|'))
                then
                (
                    get_ch(Ch1, !Inp, !IO),
                    Ch1 = {IChar1, _, _},
                    (
                        if (IChar1 = to_int('|'))
                        then
                        (
                            TokTup = {token_OR, "||", LN, CN}
                        )
                        else throw("Error: unexpected character '" ++
                                   from_char(Char) ++ "' at " ++
                                   from_int(LN) ++ ":" ++
                                   from_int(CN))
                    )
                )
                else if (Char = ('"'))
                then
                (
                    push_back(Ch, !Inp),
                    scan_string_literal(TokTup, !Inp, !IO)
                )
                else if (Char = ('\''))
                then
                (
                    push_back(Ch, !Inp),
                    scan_character_literal(TokTup, !Inp, !IO)
                )
                else if (is_alpha(Char))
                then
                (
                    push_back(Ch, !Inp),
                    scan_identifier_or_reserved_word(
                        TokTup, !Inp, !IO)
                )
                else if (is_digit(Char))
                then
                (
                    push_back(Ch, !Inp),
                    scan_integer_literal(TokTup, !Inp, !IO)
                )
                else
                (
                    throw("Error: unexpected character '" ++
                          from_char(Char) ++ "' at " ++
                          from_int(LN) ++ ":" ++
                          from_int(CN))
                )
            )
        )
    ).

:- pred skip_spaces_and_comments(inp_t::in, inp_t::out,
                                 io::di, io::uo) is det.
skip_spaces_and_comments(!Inp, !IO) :-
    get_ch(Ch, !Inp, !IO),
    Ch = {IChar, _, _},
    (
        if (IChar = eof)
        then push_back(Ch, !Inp)
        else
        if (is_whitespace(det_from_int(IChar)))
        then skip_spaces_and_comments(!Inp, !IO)
        else if (IChar = to_int('/'))
        then
        (
            get_ch(Ch1, !Inp, !IO),
            Ch1 = {IChar1, Line_no, Column_no},
            (
                if (IChar1 = to_int('*'))
                then
                (
                    scan_comment(Line_no, Column_no,
                                 !Inp, !IO),
                    skip_spaces_and_comments(!Inp, !IO)
                )
                else
                (
                    push_back(Ch1, !Inp),
                    push_back(Ch, !Inp)
                )
            )
        )
        else push_back(Ch, !Inp)
    ).

:- pred scan_comment(int::in, int::in, % line and column nos.
                     inp_t::in, inp_t::out,
                     io::di, io::uo) is det.
scan_comment(Line_no, Column_no, !Inp, !IO) :-
    get_ch(Ch, !Inp, !IO),
    {IChar, _, _} = Ch,
    (
        if (IChar = eof)
        then throw("Error: unterminated comment " ++
                   "starting at " ++ from_int(Line_no) ++ ":" ++
                   from_int(Column_no))
        else
        (
            det_from_int(IChar) = Char,
            (
                if (Char = ('*'))
                then
                (
                    get_ch(Ch1, !Inp, !IO),
                    {IChar1, _, _} = Ch1,
                    (
                        if (IChar1 = to_int('/'))
                        then true % End of comment has been reached.
                        else
                        (
                            push_back(Ch1, !Inp),
                            scan_comment(Line_no, Column_no, !Inp,
                                         !IO)
                        )
                    )
                )
                else scan_comment(Line_no, Column_no, !Inp, !IO)
            )
        )
    ).

:- pred scan_character_literal(toktup_t::out,
                               inp_t::in, inp_t::out,
                               io::di, io::uo) is det.
scan_character_literal(TokTup, !Inp, !IO) :-
    get_ch(Ch, !Inp, !IO),
    Ch = {OpenQuote, Line_no, Column_no},
    CloseQuote = OpenQuote,
    scan_char_lit_contents(CodePoint, Line_no, Column_no,
                           !Inp, !IO),
    check_char_lit_end(CloseQuote, Line_no, Column_no, !Inp, !IO),
    Arg = from_int(CodePoint),
    TokTup = {token_INTEGER, Arg, Line_no, Column_no}.

:- pred scan_char_lit_contents(int::out, int::in, int::in,
                               inp_t::in, inp_t::out,
                               io::di, io::uo) is det.
scan_char_lit_contents(CodePoint, Line_no, Column_no,
                       !Inp, !IO) :-
    get_ch(Ch1, !Inp, !IO),
    Ch1 = {IChar1, Line_no1, Column_no1},
    (
        if (IChar1 = eof)
        then throw("Error: end of input in character literal " ++
                   "starting at " ++ from_int(Line_no) ++ ":" ++
                   from_int(Column_no))
        else if (IChar1 = to_int('\\'))
        then
        (
            get_ch(Ch2, !Inp, !IO),
            Ch2 = {IChar2, _, _},
            (if (IChar2 = eof)
             then throw("Error: end of input in character literal " ++
                        "starting at " ++ from_int(Line_no) ++ ":" ++
                        from_int(Column_no))
             else if (IChar2 = to_int('n'))
             then (CodePoint = to_int('\n'))
             else if (IChar2 = to_int('\\'))
             then (CodePoint = to_int('\\'))
             else throw("Error: unsupported escape \\" ++
                        from_char(det_from_int(IChar2)) ++
                        " at " ++ from_int(Line_no1) ++
                        ":" ++ from_int(Column_no1))
            )
        )
        else (CodePoint = IChar1)
    ).

:- pred check_char_lit_end(int::in, int::in, int::in,
                           inp_t::in, inp_t::out,
                           io::di, io::uo) is det.
check_char_lit_end(CloseQuote, Line_no, Column_no, !Inp, !IO) :-
    get_ch(Ch1, !Inp, !IO),
    Ch1 = {IChar1, _, _},
    (
        if (IChar1 = CloseQuote)
        then true
        else find_bad_char_lit_end(CloseQuote, Line_no, Column_no,
                                   !Inp, !IO)
    ).

:- pred find_bad_char_lit_end(int::in, int::in, int::in,
                              inp_t::in, inp_t::out,
                              io::di, io::uo) is det.
find_bad_char_lit_end(CloseQuote, Line_no, Column_no, !Inp, !IO) :-
    get_ch(Ch2, !Inp, !IO),
    Ch2 = {IChar2, _, _},
    (
        if (IChar2 = CloseQuote)
        then throw("Error: unsupported multicharacter literal " ++
                   " at " ++ from_int(Line_no) ++ ":" ++
                   from_int(Column_no))
        else if (IChar2 = eof)
        then throw("Error: end of input in character literal " ++
                   " at " ++ from_int(Line_no) ++ ":" ++
                   from_int(Column_no))
        else find_bad_char_lit_end(CloseQuote, Line_no, Column_no,
                                   !Inp, !IO)
    ).

:- pred scan_string_literal(toktup_t::out,
                            inp_t::in, inp_t::out,
                            io::di, io::uo) is det.
scan_string_literal(TokTup, !Inp, !IO) :-
    get_ch(Ch, !Inp, !IO),
    Ch = {OpenQuote, Line_no, Column_no},
    CloseQuote = OpenQuote,
    scan_string_lit_contents("", Str, CloseQuote,
                             Line_no, Column_no,
                             !Inp, !IO),
    Arg = from_char(det_from_int(OpenQuote)) ++
          Str ++ from_char(det_from_int(CloseQuote)),
    TokTup = {token_STRING, Arg, Line_no, Column_no}.

:- pred scan_string_lit_contents(string::in, string::out, int::in,
                                 int::in, int::in,
                                 inp_t::in, inp_t::out,
                                 io::di, io::uo) is det.
scan_string_lit_contents(Str0, Str, CloseQuote, Line_no, Column_no,
                         !Inp, !IO) :-
    get_ch(Ch1, !Inp, !IO),
    Ch1 = {IChar1, Line_no1, Column_no1},
    (
        if (IChar1 = CloseQuote)
        then (Str = Str0)
        else if (IChar1 = eof)
        then throw("Error: end of input in string literal " ++
                   "starting at " ++ from_int(Line_no) ++ ":" ++
                   from_int(Column_no))
        else if (IChar1 = to_int('\n'))
        then throw("Error: end of line in string literal " ++
                   "starting at " ++ from_int(Line_no) ++ ":" ++
                   from_int(Column_no))
        else if (IChar1 = to_int('\\'))
        then
        (
            get_ch(Ch2, !Inp, !IO),
            Ch2 = {IChar2, _, _},
            (
                if (IChar2 = to_int('n'))
                then
                (
                    Str1 = Str0 ++ "\\n",
                    scan_string_lit_contents(Str1, Str, CloseQuote,
                                             Line_no, Column_no,
                                             !Inp, !IO)
                )
                else if (IChar2 = to_int('\\'))
                then
                (
                    Str1 = Str0 ++ "\\\\",
                    scan_string_lit_contents(Str1, Str, CloseQuote,
                                             Line_no, Column_no,
                                             !Inp, !IO)
                )
                else if (IChar2 = eof)
                then throw("Error: end of input in string literal " ++
                           "starting at " ++ from_int(Line_no) ++
                           ":" ++ from_int(Column_no))
                else if (IChar2 = to_int('\n'))
                then throw("Error: end of line in string literal " ++
                           "starting at " ++ from_int(Line_no) ++
                           ":" ++ from_int(Column_no))
                else throw("Error: unsupported escape \\" ++
                           from_char(det_from_int(IChar2)) ++
                           " at " ++ from_int(Line_no1) ++
                           ":" ++ from_int(Column_no1))
            )
        )
        else
        (
            Char1 = det_from_int(IChar1),
            Str1 = Str0 ++ from_char(Char1),
            scan_string_lit_contents(Str1, Str, CloseQuote,
                                     Line_no, Column_no, !Inp, !IO)
        )
    ).

:- pred scan_identifier_or_reserved_word(toktup_t::out,
                                         inp_t::in, inp_t::out,
                                         io::di, io::uo) is det.
scan_identifier_or_reserved_word(TokTup, !Inp, !IO) :-
    scan_integer_or_word(Str, Line_no, Column_no, !Inp, !IO),
    (
        if (Str = "if")
        then (TokTup = {token_IF, Str, Line_no, Column_no})
        else if (Str = "else")
        then (TokTup = {token_ELSE, Str, Line_no, Column_no})
        else if (Str = "while")
        then (TokTup = {token_WHILE, Str, Line_no, Column_no})
        else if (Str = "print")
        then (TokTup = {token_PRINT, Str, Line_no, Column_no})
        else if (Str = "putc")
        then (TokTup = {token_PUTC, Str, Line_no, Column_no})
        else (TokTup = {token_IDENTIFIER, Str, Line_no, Column_no})
    ).

:- pred scan_integer_literal(toktup_t::out, inp_t::in, inp_t::out,
                             io::di, io::uo) is det.
scan_integer_literal(TokTup, !Inp, !IO) :-
    scan_integer_or_word(Str, Line_no, Column_no, !Inp, !IO),
    (
        if (not is_all_digits(Str))
        then throw("Error: not a valid integer literal: " ++ Str)
        else (TokTup = {token_INTEGER, Str, Line_no, Column_no})
    ).

:- pred scan_integer_or_word(string::out, int::out, int::out,
                             inp_t::in, inp_t::out,
                             io::di, io::uo) is det.
scan_integer_or_word(Str, Line_no, Column_no, !Inp, !IO) :-
    get_ch({IChar, Line_no, Column_no}, !Inp, !IO),
    (
        if (IChar = eof)
        then throw("internal error")
        else
        (
            Char = det_from_int(IChar),
            (if (not is_alnum_or_underscore(Char))
             then throw("internal error")
             else scan_int_or_word(from_char(Char), Str, !Inp, !IO))
        )
    ).

:- pred scan_int_or_word(string::in, string::out,
                         inp_t::in, inp_t::out,
                         io::di, io::uo) is det.
scan_int_or_word(Str0, Str, !Inp, !IO) :-
    get_ch(CharTup, !Inp, !IO),
    {IChar, _, _} = CharTup,
    (
        if (IChar = eof)
        then
        (
            push_back(CharTup, !Inp),
            Str = Str0
        )
        else
        (
            Char = det_from_int(IChar),
            (
                if (not is_alnum_or_underscore(Char))
                then
                (
                    push_back(CharTup, !Inp),
                    Str = Str0
                )
                else scan_int_or_word(Str0 ++ from_char(Char), Str,
                                      !Inp, !IO)
            )
        )
    ).

:- pred init(text_input_stream::in, inp_t::out) is det.
init(Inpf, Inp) :-
    Inp = inp_t(Inpf, 1, 1, init).

:- pred get_ch(ch_t::out, inp_t::in, inp_t::out,
               io::di, io::uo) is det.
get_ch(Ch, Inp0, Inp, !IO) :-
    if (pop(Ch1, Inp0^pushback, Pushback))
    then
    (
        Ch = Ch1,
        Inp = (Inp0^pushback := Pushback)
    )
    else
    (
        inp_t(Inpf, Line_no, Column_no, Pushback) = Inp0,
        read_char_unboxed(Inpf, Result, Char, !IO),
        (
            if (Result = ok)
            then
            (
                Ch = {to_int(Char), Line_no, Column_no},
                Inp =
                (if (Char = ('\n'))
                 then inp_t(Inpf, Line_no + 1, 1, Pushback)
                 else inp_t(Inpf, Line_no, Column_no + 1, Pushback))
            )
            else
            (
                Ch = {eof, Line_no, Column_no},
                Inp = Inp0
            )
        )
    ).

:- pred push_back(ch_t::in, inp_t::in, inp_t::out) is det.
push_back(Ch, Inp0, Inp) :-
    Inp = (Inp0^pushback := push(Inp0^pushback, Ch)).

:- func eof = int is det.
eof = -1.


import re, strformat, strutils

type
  TokenKind = enum
    tkUnknown = "UNKNOWN_TOKEN",
    tkMul = "Op_multiply",
    tkDiv = "Op_divide",
    tkMod = "Op_mod",
    tkAdd = "Op_add",
    tkSub = "Op_subtract",
    tkNeg = "Op_negate",
    tkLt = "Op_less",
    tkLte = "Op_lessequal",
    tkGt = "Op_greater",
    tkGte = "Op_greaterequal",
    tkEq = "Op_equal",
    tkNeq = "Op_notequal",
    tkNot = "Op_not",
    tkAsgn = "Op_assign",
    tkAnd = "Op_and",
    tkOr = "Op_or",
    tkLpar = "LeftParen",
    tkRpar = "RightParen",
    tkLbra = "LeftBrace",
    tkRbra = "RightBrace",
    tkSmc = "Semicolon",
    tkCom = "Comma",
    tkIf = "Keyword_if",
    tkElse = "Keyword_else",
    tkWhile = "Keyword_while",
    tkPrint = "Keyword_print",
    tkPutc = "Keyword_putc",
    tkId = "Identifier",
    tkInt = "Integer",
    tkChar = "Integer",
    tkStr = "String",
    tkEof = "End_of_input"

  Token = object
    kind: TokenKind
    value: string

  TokenAnn = object
    ## Annotated token with messages for compiler
    token: Token
    line, column: int

proc getSymbols(table: openArray[(char, TokenKind)]): seq[char] =
  result = newSeq[char]()
  for ch, tokenKind in items(table):
    result.add ch

const
  tkSymbols = { # single-char tokens
    '*': tkMul,
    '%': tkMod,
    '+': tkAdd,
    '-': tkSub,
    '(': tkLpar,
    ')': tkRpar,
    '{': tkLbra,
    '}': tkRbra,
    ';': tkSmc,
    ',': tkCom,
    '/': tkDiv, # the comment case /* ... */ is handled in `stripUnimportant`
  }
  symbols = getSymbols(tkSymbols)

proc findTokenKind(table: openArray[(char, TokenKind)]; needle: char):
                  TokenKind =
  for ch, tokenKind in items(table):
    if ch == needle: return tokenKind
  tkUnknown

proc stripComment(text: var string, lineNo, colNo: var int) =
  var matches: array[1, string]

  if match(text, re"\A(/\*[\s\S]*?\*/)", matches):
    text = text[matches[0].len..^1]
    for s in matches[0]:
      if s == '\n':
        inc lineNo
        colNo = 1
      else:
        inc colNo

proc stripUnimportant(text: var string; lineNo, colNo: var int) =
  while true:
    if text.len == 0: return
    elif text[0] == '\n':
      inc lineNo
      colNo = 1
      text = text[1..^1]
    elif text[0] == ' ':
      inc colNo
      text = text[1..^1]
    elif text.len >= 2 and text[0] == '/' and text[1] == '*':
      stripComment(text, lineNo, colNo)
    else: return

proc lookAhead(ch1, ch2: char, tk1, tk2: TokenKind): (TokenKind, int) =
  if ch1 == ch2: (tk1, 2)
  else: (tk2, 1)

proc consumeToken(text: var string; tkl: var int): Token =
  ## Return token removing it from the `text` and write its length to
  ## `tkl`.  If the token can not be defined, return `tkUnknown` as a
  ## token, shrink text by 1 and write 1 to its length.

  var
    matches: array[1, string]
    tKind: TokenKind
    val: string

  if text.len == 0:
    (tKind, tkl) = (tkEof, 0)

  # Simple characters
  elif text[0] in symbols: (tKind, tkl) = (tkSymbols.findTokenKind(text[0]), 1)
  elif text[0] == '<': (tKind, tkl) = lookAhead(text[1], '=', tkLte, tkLt)
  elif text[0] == '>': (tKind, tkl) = lookAhead(text[1], '=', tkGte, tkGt)
  elif text[0] == '=': (tKind, tkl) = lookAhead(text[1], '=', tkEq, tkAsgn)
  elif text[0] == '!': (tKind, tkl) = lookAhead(text[1], '=', tkNeq, tkNot)
  elif text[0] == '&': (tKind, tkl) = lookAhead(text[1], '&', tkAnd, tkUnknown)
  elif text[0] == '|': (tKind, tkl) = lookAhead(text[1], '|', tkOr, tkUnknown)

  # Keywords
  elif match(text, re"\Aif\b"): (tKind, tkl) = (tkIf, 2)
  elif match(text, re"\Aelse\b"): (tKind, tkl) = (tkElse, 4)
  elif match(text, re"\Awhile\b"): (tKind, tkl) = (tkWhile, 5)
  elif match(text, re"\Aprint\b"): (tKind, tkl) = (tkPrint, 5)
  elif match(text, re"\Aputc\b"): (tKind, tkl) = (tkPutc, 4)

  # Literals and identifiers
  elif match(text, re"\A([0-9]+)", matches):
    (tKind, tkl) = (tkInt, matches[0].len)
    val = matches[0]
  elif match(text, re"\A([_a-zA-Z][_a-zA-Z0-9]*)", matches):
    (tKind, tkl) = (tkId, matches[0].len)
    val = matches[0]
  elif match(text, re"\A('(?:[^'\n]|\\\\|\\n)')", matches):
    (tKind, tkl) = (tkChar, matches[0].len)
    val = case matches[0]
          of r"' '": $ord(' ')
          of r"'\n'": $ord('\n')
          of r"'\\'": $ord('\\')
          else: $ord(matches[0][1]) # "'a'"[1] == 'a'
  elif match(text, re"\A(""[^""\n]*"")", matches):
    (tKind, tkl) = (tkStr, matches[0].len)
    val = matches[0]
  else: (tKind, tkl) = (tkUnknown, 1)

  text = text[tkl..^1]
  Token(kind: tKind, value: val)

proc tokenize*(text: string): seq[TokenAnn] =
  result = newSeq[TokenAnn]()
  var
    lineNo, colNo: int = 1
    text = text
    token: Token
    tokenLength: int

  while text.len > 0:
    stripUnimportant(text, lineNo, colNo)
    token = consumeToken(text, tokenLength)
    result.add TokenAnn(token: token, line: lineNo, column: colNo)
    inc colNo, tokenLength

proc output*(s: seq[TokenAnn]): string =
  var
    tokenKind: TokenKind
    value: string
    line, column: int

  for tokenAnn in items(s):
    line = tokenAnn.line
    column = tokenAnn.column
    tokenKind = tokenAnn.token.kind
    value = tokenAnn.token.value
    result.add(
      fmt"{line:>5}{column:>7} {tokenKind:<15}{value}"
        .strip(leading = false) & "\n")

when isMainModule:
  import os

  let input = if paramCount() > 0: readFile paramStr(1)
              else: readAll stdin

  echo input.tokenize.output


# -*- ObjectIcon -*-
#
# The Rosetta Code lexical analyzer in Object Icon. Based upon the ATS
# implementation.
#
# Usage: lex [INPUTFILE [OUTPUTFILE]]
#   If INPUTFILE or OUTPUTFILE is "-" or missing, then standard input
#   or standard output is used, respectively. *)
#

import io

$define EOF -1

$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

global whitespace
global ident_start
global ident_continuation

procedure main(args)
  local inpf, outf
  local pushback_buffer, inp, pushback

  initial {
    whitespace := ' \t\v\f\r\n'
    ident_start := '_' ++ &letters
    ident_continuation := ident_start ++ &digits
  }

  inpf := FileStream.stdin
  outf := FileStream.stdout
  if 1 <= *args & args[1] ~== "-" then {
    inpf := FileStream(args[1], FileOpt.RDONLY) | stop(&why)
  }
  if 2 <= *args & args[2] ~== "-" then {
    outf := FileStream(args[2], ior(FileOpt.WRONLY,
                                    FileOpt.TRUNC,
                                    FileOpt.CREAT)) | stop(&why)
  }

  pushback_buffer := []
  inp := create inputter(inpf, pushback_buffer)
  pushback := create repeat push(pushback_buffer, \@&source)
  @pushback                     #  The first invocation does nothing.

  scan_text(outf, inp, pushback)
end

procedure scan_text(outf, inp, pushback)
  local ch

  while /ch | ch[1] ~=== EOF do {
    skip_spaces_and_comments(inp, pushback)
    ch := @inp
    if ch[1] === EOF then {
      print_token(outf, [TOKEN_END_OF_INPUT, "", ch[2], ch[3]])
    } else {
      ch @pushback
      print_token(outf, get_next_token(inp, pushback))
    }
  }
end

procedure get_next_token(inp, pushback)
  local ch, ch1
  local ln, cn

  skip_spaces_and_comments(inp, pushback)
  ch := @inp
  ln := ch[2]                   # line number
  cn := ch[3]                   # column number
  case ch[1] of {
    "," : return [TOKEN_COMMA, ",", ln, cn]
    ";" : return [TOKEN_SEMICOLON, ";", ln, cn]
    "(" : return [TOKEN_LEFTPAREN, "(", ln, cn]
    ")" : return [TOKEN_RIGHTPAREN, ")", ln, cn]
    "{" : return [TOKEN_LEFTBRACE, "{", ln, cn]
    "}" : return [TOKEN_RIGHTBRACE, "}", ln, cn]
    "*" : return [TOKEN_MULTIPLY, "*", ln, cn]
    "/" : return [TOKEN_DIVIDE, "/", ln, cn]
    "%" : return [TOKEN_MOD, "%", ln, cn]
    "+" : return [TOKEN_ADD, "+", ln, cn]
    "-" : return [TOKEN_SUBTRACT, "-", ln, cn]
    "<" : {
      ch1 := @inp
      if ch1[1] === "=" then {
        return [TOKEN_LESSEQUAL, "<=", ln, cn]
      } else {
        ch1 @pushback
        return [TOKEN_LESS, "<", ln, cn]
      }
    }
    ">" : {
      ch1 := @inp
      if ch1[1] === "=" then {
        return [TOKEN_GREATEREQUAL, ">=", ln, cn]
      } else {
        ch1 @pushback
        return [TOKEN_GREATER, ">", ln, cn]
      }
    }
    "=" : {
      ch1 := @inp
      if ch1[1] === "=" then {
        return [TOKEN_EQUAL, "==", ln, cn]
      } else {
        ch1 @pushback
        return [TOKEN_ASSIGN, "=", ln, cn]
      }
    }
    "!" : {
      ch1 := @inp
      if ch1[1] === "=" then {
        return [TOKEN_NOTEQUAL, "!=", ln, cn]
      } else {
        ch1 @pushback
        return [TOKEN_NOT, "!", ln, cn]
      }
    }
    "&" : {
      ch1 := @inp
      if ch1[1] === "&" then {
        return [TOKEN_AND, "&&", ln, cn]
      } else {
        unexpected_character(ln, cn, ch)
      }
    }
    "|" : {
      ch1 := @inp
      if ch1[1] === "|" then {
        return [TOKEN_OR, "||", ln, cn]
      } else {
        unexpected_character(ln, cn, ch)
      }
    }
    "\"" : {
      ch @pushback
      return scan_string_literal(inp)
    }
    "'" : {
      ch @pushback
      return scan_character_literal(inp, pushback)
    }
    default : {
      if any(&digits, ch[1]) then {
        ch @pushback
        return scan_integer_literal(inp, pushback)
      } else if any(ident_start, ch[1]) then {
        ch @pushback
        return scan_identifier_or_reserved_word (inp, pushback)
      } else {
        unexpected_character(ln, cn, ch)
      }
    }
  }
end

procedure scan_identifier_or_reserved_word(inp, pushback)
  local ch
  local s
  local line_no, column_no

  s := ""
  ch := @inp
  line_no := ch[2]
  column_no := ch[3]
  while EOF ~=== ch[1] & any(ident_continuation, ch[1]) do {
    s ||:= ch[1]
    ch := @inp
  }
  ch @pushback
  return reserved_word_lookup (s, line_no, column_no)
end

procedure scan_integer_literal(inp, pushback)
  local ch
  local s
  local line_no, column_no

  s := ""
  ch := @inp
  line_no := ch[2]
  column_no := ch[3]
  while EOF ~=== ch[1] & any(ident_continuation, ch[1]) do {
    s ||:= ch[1]
    ch := @inp
  }
  ch @pushback
  not upto(~&digits, s) | invalid_integer_literal(line_no, column_no, s)
  return [TOKEN_INTEGER, s, line_no, column_no]
end

procedure scan_character_literal(inp, pushback)
  local ch, ch1
  local close_quote
  local toktup
  local line_no, column_no

  ch := @inp                    # The opening quote.
  close_quote := ch[1]          # Same as the opening quote.
  ch @pushback

  line_no := ch[2]
  column_no := ch[3]

  toktup := scan_character_literal_without_checking_end(inp)
  ch1 := @inp
  if ch1[1] ~=== close_quote then {
    repeat {
      case ch1[1] of {
        EOF : unterminated_character_literal(line_no, column_no)
        close_quote : multicharacter_literal(line_no, column_no)
        default : ch1 := @inp
      }
    }
  }
  return toktup
end

procedure scan_character_literal_without_checking_end(inp)
  local ch, ch1, ch2

  ch := @inp                    # The opening quote.
  ch1 := @inp
  EOF ~=== ch1[1] | unterminated_character_literal(ch[2], ch[3])
  if ch1[1] == "\\" then {
    ch2 := @inp
    EOF ~=== ch2[1] | unterminated_character_literal(ch[2], ch[3])
    case ch2[1] of {
      "n" : return [TOKEN_INTEGER, string(ord("\n")), ch[2], ch[3]]
      "\\" : return [TOKEN_INTEGER, string(ord("\\")), ch[2], ch[3]]
      default : unsupported_escape(ch1[2], ch1[3], ch2)
    }
  } else {
    return [TOKEN_INTEGER, string(ord(ch1[1])), ch[2], ch[3]]
  }
end

procedure scan_string_literal(inp)
  local ch, ch1, ch2
  local line_no, column_no
  local close_quote
  local s
  local retval

  ch := @inp                    # The opening quote
  close_quote := ch[1]          # Same as the opening quote.
  line_no := ch[2]
  column_no := ch[3]

  s := ch[1]
  until \retval do {
    ch1 := @inp
    ch1[1] ~=== EOF |
        unterminated_string_literal (line_no, column_no,
                                     "end of input")
    ch1[1] ~== "\n" |
        unterminated_string_literal (line_no, column_no,
                                     "end of line")
    if ch1[1] == close_quote then {
      retval := [TOKEN_STRING, s || close_quote, line_no, column_no]
    } else if ch1[1] ~== "\\" then {
      s ||:= ch1[1]
    } else {
      ch2 := @inp
      EOF ~=== ch2[1] | unsupported_escape(line_no, column_no, ch2)
      case ch2[1] of {
        "n" : s ||:= "\\n"
        "\\" : s ||:= "\\\\"
        default : unsupported_escape(line_no, column_no, ch2)
      }
    }
  }
  return retval
end

procedure skip_spaces_and_comments(inp, pushback)
  local ch, ch1

  repeat {
    ch := @inp
    (EOF === ch[1]) & { ch @pushback; return }
    if not any(whitespace, ch[1]) then {
      (ch[1] == "/") | { ch @pushback; return }
      (ch1 := @inp) | { ch @pushback; return }
      (ch1[1] == "*") | { ch1 @pushback; ch @pushback; return }
      scan_comment(inp, ch[2], ch[3])
    }
  }
end

procedure scan_comment(inp, line_no, column_no)
  local ch, ch1

  until (\ch)[1] == "*" & (\ch1)[1] == "/" do {
    ch := @inp
    (EOF === ch[1]) & unterminated_comment(line_no, column_no)
    if ch[1] == "*" then {
      ch1 := @inp
      (EOF === ch[1]) & unterminated_comment(line_no, column_no)
    }
  }
  return
end

procedure reserved_word_lookup(s, line_no, column_no)

  # Lookup is by an extremely simple perfect hash.

  static reserved_words
  static reserved_word_tokens
  local hashval, token, toktup

  initial {
    reserved_words := ["if", "print", "else",
                       "", "putc", "",
                       "", "while", ""]
    reserved_word_tokens :=
        [TOKEN_IF, TOKEN_PRINT, TOKEN_ELSE,
         TOKEN_IDENTIFIER, TOKEN_PUTC, TOKEN_IDENTIFIER,
         TOKEN_IDENTIFIER, TOKEN_WHILE, TOKEN_IDENTIFIER]
  }

  if *s < 2 then {
    toktup := [TOKEN_IDENTIFIER, s, line_no, column_no]
  } else {
    hashval := ((ord(s[1]) + ord(s[2])) % (*reserved_words)) + 1
    token := reserved_word_tokens[hashval]
    if token = TOKEN_IDENTIFIER | s ~== reserved_words[hashval] then {
      toktup := [TOKEN_IDENTIFIER, s, line_no, column_no]
    } else {
      toktup := [token, s, line_no, column_no]
    }
  }
  return toktup
end

procedure print_token(outf, toktup)
  static token_names
  local s_line, s_column

  initial {
    token_names := ["Keyword_else",
                    "Keyword_if",
                    "Keyword_print",
                    "Keyword_putc",
                    "Keyword_while",
                    "Op_multiply",
                    "Op_divide",
                    "Op_mod",
                    "Op_add",
                    "Op_subtract",
                    "Op_negate",
                    "Op_less",
                    "Op_lessequal",
                    "Op_greater",
                    "Op_greaterequal",
                    "Op_equal",
                    "Op_notequal",
                    "Op_not",
                    "Op_assign",
                    "Op_and",
                    "Op_or",
                    "LeftParen",
                    "RightParen",
                    "LeftBrace",
                    "RightBrace",
                    "Semicolon",
                    "Comma",
                    "Identifier",
                    "Integer",
                    "String",
                    "End_of_input"]
  }

  /outf := FileStream.stdout
  s_line := string(toktup[3])
  s_column := string(toktup[4])
  writes(outf, right (s_line, max(5, *s_line)))
  writes(outf, " ")
  writes(outf, right (s_column, max(5, *s_column)))
  writes(outf, "  ")
  writes(outf, token_names[toktup[1] + 1])
  case toktup[1] of {
    TOKEN_IDENTIFIER : writes(outf, "     ", toktup[2])
    TOKEN_INTEGER : writes(outf, "        ", toktup[2])
    TOKEN_STRING : writes(outf, "         ", toktup[2])
  }
  write(outf)
  return
end

procedure inputter(inpf, pushback_buffer)
  local buffer
  local line_no, column_no
  local c

  buffer := ""
  line_no := 1
  column_no := 1

  repeat {
      buffer? {
        until *pushback_buffer = 0 & pos(0) do {
          if *pushback_buffer ~= 0 then {
            suspend pop(pushback_buffer)
          } else {
            c := move(1)
            suspend [c, line_no, column_no]
            if c == "\n" then {
              line_no +:= 1
              column_no := 1
            } else {
              column_no +:= 1
            }
          }
        }
      }
      (buffer := reads(inpf, 2048)) |
          suspend [EOF, line_no, column_no]
    }
end

procedure unterminated_comment(line_no, column_no)
  error("unterminated comment starting at ",
        line_no, ":", column_no)
end

procedure unexpected_character(line_no, column_no, ch)
  error("unexpected character '", ch[1], "' starting at ",
        line_no, ":", column_no)
end

procedure unterminated_string_literal (line_no, column_no, cause)
  error("unterminated string literal (", cause, ") starting at ",
        line_no, ":", column_no)
end

procedure unsupported_escape (line_no, column_no, ch)
  if ch[1] === EOF then {
    error("unexpected \\ at end of input",
          " starting at ", line_no, ":", column_no)
  } else {
    error("unsupported escape \\", ch[1],
          " starting at ", line_no, ":", column_no)
  }
end

procedure invalid_integer_literal(line_no, column_no, s)
  error("invalid integer literal ", s,
        " starting at ", line_no, ":", column_no)
end

procedure unterminated_character_literal(line_no, column_no)
  error("unterminated character literal starting at ",
        line_no, ":", column_no)
end

procedure multicharacter_literal(line_no, column_no)
  error("unsupported multicharacter literal starting at ",
        line_no, ":", column_no)
end

procedure error(args[])
  write!([FileStream.stderr] ||| args)
  exit(1)
end


(*------------------------------------------------------------------*)
(* The Rosetta Code lexical analyzer, in OCaml. Based on the ATS.   *)

(* When you compare this code to the ATS code, please keep in mind
   that, although ATS has an ML-like syntax:

    * The type system is not the same at all.

    * Most ATS functions are not closures. Those that are will have
   special notations such as "<cloref1>" associated with them. *)

(*------------------------------------------------------------------*)
(* The following functions are compatible with ASCII. *)

let is_digit ichar =
  48 <= ichar && ichar <= 57

let is_lower ichar =
  97 <= ichar && ichar <= 122

let is_upper ichar =
  65 <= ichar && ichar <= 90

let is_alpha ichar =
  is_lower ichar || is_upper ichar

let is_alnum ichar =
  is_digit ichar || is_alpha ichar

let is_ident_start ichar =
  is_alpha ichar || ichar = 95

let is_ident_continuation ichar =
  is_alnum ichar || ichar = 95

let is_space ichar =
  ichar = 32 || (9 <= ichar && ichar <= 13)

(*------------------------------------------------------------------*)

let reverse_list_to_string lst =
  List.rev lst |> List.to_seq |> String.of_seq

(*------------------------------------------------------------------*)
(* Character input more like that of C. There are various advantages
   and disadvantages to this method, but key points in its favor are:
   (a) it is how character input is done in the original ATS code, (b)
   Unicode code points are 21-bit positive integers. *)

let eof = (-1)

let input_ichar channel =
  try
    int_of_char (input_char channel)
  with
  | End_of_file -> eof

(*------------------------------------------------------------------*)

(* The type of an input character. *)

module Ch =
  struct
    type t =
      {
        ichar : int;
        line_no : int;
        column_no : int
      }
  end

(*------------------------------------------------------------------*)
(* Inputting with unlimited pushback, and with counting of lines and
   columns. *)

module Inp =
  struct
    type t =
      {
        inpf : in_channel;
        pushback : Ch.t list;
        line_no : int;
        column_no : int
      }

    let of_in_channel inpf =
      { inpf = inpf;
        pushback = [];
        line_no = 1;
        column_no = 1
      }

    let get_ch inp =
      match inp.pushback with
      | ch :: tail ->
         (ch, {inp with pushback = tail})
      | [] ->
         let ichar = input_ichar inp.inpf in
         if ichar = int_of_char '\n' then
           ({ ichar = ichar;
              line_no = inp.line_no;
              column_no = inp.column_no },
            { inp with line_no = inp.line_no + 1;
                       column_no = 1 })
         else
           ({ ichar = ichar;
              line_no = inp.line_no;
              column_no = inp.column_no },
            { inp with column_no = inp.column_no + 1 })

    let push_back_ch ch inp =
      {inp with pushback = ch :: inp.pushback}
  end

(*------------------------------------------------------------------*)
(* Tokens, appearing in tuples with arguments, and with line and
   column numbers. The tokens are integers, so they can be used as
   array indices. *)

(* (token, argument, line_no, column_no) *)
type toktup_t = int * string * int * int

let token_ELSE         =  0
let token_IF           =  1
let token_PRINT        =  2
let token_PUTC         =  3
let token_WHILE        =  4
let token_MULTIPLY     =  5
let token_DIVIDE       =  6
let token_MOD          =  7
let token_ADD          =  8
let token_SUBTRACT     =  9
let token_NEGATE       = 10
let token_LESS         = 11
let token_LESSEQUAL    = 12
let token_GREATER      = 13
let token_GREATEREQUAL = 14
let token_EQUAL        = 15
let token_NOTEQUAL     = 16
let token_NOT          = 17
let token_ASSIGN       = 18
let token_AND          = 19
let token_OR           = 20
let token_LEFTPAREN    = 21
let token_RIGHTPAREN   = 22
let token_LEFTBRACE    = 23
let token_RIGHTBRACE   = 24
let token_SEMICOLON    = 25
let token_COMMA        = 26
let token_IDENTIFIER   = 27
let token_INTEGER      = 28
let token_STRING       = 29
let token_END_OF_INPUT = 30
;;

(* A *very* simple perfect hash for the reserved words. (Yes, this is
   overkill, except for demonstration of the principle.) *)

let reserved_words =
  [| "if"; "print"; "else"; ""; "putc"; ""; ""; "while"; "" |]
let reserved_word_tokens =
  [| token_IF; token_PRINT; token_ELSE; token_IDENTIFIER;
     token_PUTC; token_IDENTIFIER; token_IDENTIFIER; token_WHILE;
     token_IDENTIFIER |]

let reserved_word_lookup s line_no column_no =
  if String.length s < 2 then
    (token_IDENTIFIER, s, line_no, column_no)
  else
    let hashval = (int_of_char s.[0] + int_of_char s.[1]) mod 9 in
    let token = reserved_word_tokens.(hashval) in
    if token = token_IDENTIFIER || s <> reserved_words.(hashval) then
      (token_IDENTIFIER, s, line_no, column_no)
    else
      (token, s, line_no, column_no)

(* Token to string lookup. *)

let token_names =
  [| "Keyword_else";
     "Keyword_if";
     "Keyword_print";
     "Keyword_putc";
     "Keyword_while";
     "Op_multiply";
     "Op_divide";
     "Op_mod";
     "Op_add";
     "Op_subtract";
     "Op_negate";
     "Op_less";
     "Op_lessequal";
     "Op_greater";
     "Op_greaterequal";
     "Op_equal";
     "Op_notequal";
     "Op_not";
     "Op_assign";
     "Op_and";
     "Op_or";
     "LeftParen";
     "RightParen";
     "LeftBrace";
     "RightBrace";
     "Semicolon";
     "Comma";
     "Identifier";
     "Integer";
     "String";
     "End_of_input" |]

let token_name token =
  token_names.(token)

(*------------------------------------------------------------------*)

exception Unterminated_comment of int * int
exception Unterminated_character_literal of int * int
exception Multicharacter_literal of int * int
exception End_of_input_in_string_literal of int * int
exception End_of_line_in_string_literal of int * int
exception Unsupported_escape of int * int * int
exception Invalid_integer_literal of int * int * string
exception Unexpected_character of int * int * char

(*------------------------------------------------------------------*)
(* Skipping past spaces and comments. (A comment in the target
   language is, if you think about it, a kind of space.) *)

let scan_comment inp line_no column_no =
  let rec loop inp =
    let (ch, inp) = Inp.get_ch inp in
    if ch.ichar = eof then
      raise (Unterminated_comment (line_no, column_no))
    else if ch.ichar = int_of_char '*' then
      let (ch1, inp) = Inp.get_ch inp in
      if ch1.ichar = eof then
        raise (Unterminated_comment (line_no, column_no))
      else if ch1.ichar = int_of_char '/' then
        inp
      else
        loop inp
    else
      loop inp
  in
  loop inp

let skip_spaces_and_comments inp =
  let rec loop inp =
    let (ch, inp) = Inp.get_ch inp in
    if is_space ch.ichar then
      loop inp
    else if ch.ichar = int_of_char '/' then
      let (ch1, inp) = Inp.get_ch inp in
      if ch1.ichar = int_of_char '*' then
        scan_comment inp ch.line_no ch.column_no |> loop
      else
        let inp = Inp.push_back_ch ch1 inp in
        let inp = Inp.push_back_ch ch inp in
        inp
    else
      Inp.push_back_ch ch inp
  in
  loop inp

(*------------------------------------------------------------------*)
(* Integer literals, identifiers, and reserved words. *)

(* In ATS the predicate for simple scan was supplied by template
   expansion, which (typically) produces faster code than passing a
   function or closure (although passing either of those could have
   been done). Here I pass the predicate as a function/closure. It is
   worth contrasting the methods. *)
let rec simple_scan pred lst inp =
  let (ch, inp) = Inp.get_ch inp in
  if pred ch.ichar then
    simple_scan pred (char_of_int ch.ichar :: lst) inp
  else
    (lst, Inp.push_back_ch ch inp)

(* Demonstration of one way to make a new closure in OCaml. (In ATS,
   one might see things that look similar but are actually template
   operations.) *)
let simple_scan_iic = simple_scan is_ident_continuation

let scan_integer_literal inp =
  let (ch, inp) = Inp.get_ch inp in
  let _ = assert (is_digit ch.ichar) in
  let (lst, inp) = simple_scan_iic [char_of_int ch.ichar] inp in
  let s = reverse_list_to_string lst in
  if List.for_all (fun c -> is_digit (int_of_char c)) lst then
    ((token_INTEGER, s, ch.line_no, ch.column_no), inp)
  else
    raise (Invalid_integer_literal (ch.line_no, ch.column_no, s))

let scan_identifier_or_reserved_word inp =
  let (ch, inp) = Inp.get_ch inp in
  let _ = assert (is_ident_start ch.ichar) in
  let (lst, inp) = simple_scan_iic [char_of_int ch.ichar] inp in
  let s = reverse_list_to_string lst in
  let toktup = reserved_word_lookup s ch.line_no ch.column_no in
  (toktup, inp)

(*------------------------------------------------------------------*)
(* String literals. *)

let scan_string_literal inp =
  let (ch, inp) = Inp.get_ch inp in
  let _ = assert (ch.ichar = int_of_char '"') in

  let rec scan lst inp =
    let (ch1, inp) = Inp.get_ch inp in
    if ch1.ichar = eof then
      raise (End_of_input_in_string_literal
               (ch.line_no, ch.column_no))
    else if ch1.ichar = int_of_char '\n' then
      raise (End_of_line_in_string_literal
               (ch.line_no, ch.column_no))
    else if ch1.ichar = int_of_char '"' then
      (lst, inp)
    else if ch1.ichar <> int_of_char '\\' then
      scan (char_of_int ch1.ichar :: lst) inp
    else
      let (ch2, inp) = Inp.get_ch inp in
      if ch2.ichar = int_of_char 'n' then
        scan ('n' :: '\\' :: lst) inp
      else if ch2.ichar = int_of_char '\\' then
        scan ('\\' :: '\\' :: lst) inp
      else
        raise (Unsupported_escape (ch1.line_no, ch1.column_no,
                                   ch2.ichar))
  in
  let lst = '"' :: [] in
  let (lst, inp) = scan lst inp in
  let lst = '"' :: lst in
  let s = reverse_list_to_string lst in
  ((token_STRING, s, ch.line_no, ch.column_no), inp)

(*------------------------------------------------------------------*)
(* Character literals. *)

let scan_character_literal_without_checking_end inp =
  let (ch, inp) = Inp.get_ch inp in
  let _ = assert (ch.ichar = int_of_char '\'') in
  let (ch1, inp) = Inp.get_ch inp in
  if ch1.ichar = eof then
    raise (Unterminated_character_literal
             (ch.line_no, ch.column_no))
  else if ch1.ichar = int_of_char '\\' then
    let (ch2, inp) = Inp.get_ch inp in
    if ch2.ichar = eof then
      raise (Unterminated_character_literal
               (ch.line_no, ch.column_no))
    else if ch2.ichar = int_of_char 'n' then
      let s = (int_of_char '\n' |> string_of_int) in
      ((token_INTEGER, s, ch.line_no, ch.column_no), inp)
    else if ch2.ichar = int_of_char '\\' then
      let s = (int_of_char '\\' |> string_of_int) in
      ((token_INTEGER, s, ch.line_no, ch.column_no), inp)
    else
      raise (Unsupported_escape
               (ch1.line_no, ch1.column_no, ch2.ichar))
  else
    let s = string_of_int ch1.ichar in
    ((token_INTEGER, s, ch.line_no, ch.column_no), inp)

let scan_character_literal inp =
  let (toktup, inp) =
    scan_character_literal_without_checking_end inp in
  let (_, _, line_no, column_no) = toktup in

  let check_end inp =
    let (ch, inp) = Inp.get_ch inp in
    if ch.ichar = int_of_char '\'' then
      inp
    else
      let rec loop_to_end (ch1 : Ch.t) inp =
        if ch1.ichar = eof then
          raise (Unterminated_character_literal (line_no, column_no))
        else if ch1.ichar = int_of_char '\'' then
          raise (Multicharacter_literal (line_no, column_no))
        else
          let (ch1, inp) = Inp.get_ch inp in
          loop_to_end ch1 inp
      in
      loop_to_end ch inp
  in
  let inp = check_end inp in
  (toktup, inp)

(*------------------------------------------------------------------*)

let get_next_token inp =
  let inp = skip_spaces_and_comments inp in
  let (ch, inp) = Inp.get_ch inp in
  let ln = ch.line_no in
  let cn = ch.column_no in
  if ch.ichar = eof then
    ((token_END_OF_INPUT, "", ln, cn), inp)
  else
    match char_of_int ch.ichar with
    | ',' -> ((token_COMMA, ",", ln, cn), inp)
    | ';' -> ((token_SEMICOLON, ";", ln, cn), inp)
    | '(' -> ((token_LEFTPAREN, "(", ln, cn), inp)
    | ')' -> ((token_RIGHTPAREN, ")", ln, cn), inp)
    | '{' -> ((token_LEFTBRACE, "{", ln, cn), inp)
    | '}' -> ((token_RIGHTBRACE, "}", ln, cn), inp)
    | '*' -> ((token_MULTIPLY, "*", ln, cn), inp)
    | '/' -> ((token_DIVIDE, "/", ln, cn), inp)
    | '%' -> ((token_MOD, "%", ln, cn), inp)
    | '+' -> ((token_ADD, "+", ln, cn), inp)
    | '-' -> ((token_SUBTRACT, "-", ln, cn), inp)
    | '<' ->
       let (ch1, inp) = Inp.get_ch inp in
       if ch1.ichar = int_of_char '=' then
         ((token_LESSEQUAL, "<=", ln, cn), inp)
       else
         let inp = Inp.push_back_ch ch1 inp in
         ((token_LESS, "<", ln, cn), inp)
    | '>' ->
       let (ch1, inp) = Inp.get_ch inp in
       if ch1.ichar = int_of_char '=' then
         ((token_GREATEREQUAL, ">=", ln, cn), inp)
       else
         let inp = Inp.push_back_ch ch1 inp in
         ((token_GREATER, ">", ln, cn), inp)
    | '=' ->
       let (ch1, inp) = Inp.get_ch inp in
       if ch1.ichar = int_of_char '=' then
         ((token_EQUAL, "==", ln, cn), inp)
       else
         let inp = Inp.push_back_ch ch1 inp in
         ((token_ASSIGN, "=", ln, cn), inp)
    | '!' ->
       let (ch1, inp) = Inp.get_ch inp in
       if ch1.ichar = int_of_char '=' then
         ((token_NOTEQUAL, "!=", ln, cn), inp)
       else
         let inp = Inp.push_back_ch ch1 inp in
         ((token_NOT, "!", ln, cn), inp)
    | '&' ->
       let (ch1, inp) = Inp.get_ch inp in
       if ch1.ichar = int_of_char '&' then
         ((token_AND, "&&", ln, cn), inp)
       else
         raise (Unexpected_character (ch.line_no, ch.column_no,
                                      char_of_int ch.ichar))
    | '|' ->
       let (ch1, inp) = Inp.get_ch inp in
       if ch1.ichar = int_of_char '|' then
         ((token_OR, "||", ln, cn), inp)
       else
         raise (Unexpected_character (ch.line_no, ch.column_no,
                                      char_of_int ch.ichar))
    | '"' ->
       let inp = Inp.push_back_ch ch inp in
       scan_string_literal inp
    | '\'' ->
       let inp = Inp.push_back_ch ch inp in
       scan_character_literal inp
    | _ when is_digit ch.ichar ->
       let inp = Inp.push_back_ch ch inp in
       scan_integer_literal inp
    | _ when is_ident_start ch.ichar ->
       let inp = Inp.push_back_ch ch inp in
       scan_identifier_or_reserved_word inp
    | _ -> raise (Unexpected_character (ch.line_no, ch.column_no,
                                        char_of_int ch.ichar))

let print_token outf toktup =
  let (token, arg, line_no, column_no) = toktup in
  let name = token_name token in
  let (padding, str) =
    match 0 with
    | _ when token = token_IDENTIFIER -> ("     ", arg)
    | _ when token = token_INTEGER -> ("        ", arg)
    | _ when token = token_STRING -> ("         ", arg)
    | _ -> ("", "")
  in
  Printf.fprintf outf "%5d %5d  %s%s%s\n"
    line_no column_no name padding str

let scan_text outf inp =
  let rec loop inp =
    let (toktup, inp) = get_next_token inp in
    begin
      print_token outf toktup;
      let (token, _, _, _) = toktup in
      if token <> token_END_OF_INPUT then
        loop inp
    end
  in
  loop inp

(*------------------------------------------------------------------*)

let main () =
  let inpf_filename =
    if 2 <= Array.length Sys.argv then
      Sys.argv.(1)
    else
      "-"
  in
  let outf_filename =
    if 3 <= Array.length Sys.argv then
      Sys.argv.(2)
    else
      "-"
  in
  let inpf =
    if inpf_filename = "-" then
      stdin
    else
      open_in inpf_filename
  in
  let outf =
    if outf_filename = "-" then
      stdout
    else
      open_out outf_filename
  in
  let inp = Inp.of_in_channel inpf in
  scan_text outf inp
;;

main ()

(*------------------------------------------------------------------*)


(import (owl parse))

(define (get-comment)
   (get-either
      (let-parses (
            (_ (get-imm #\*))
            (_ (get-imm #\/)))
         #true)
      (let-parses (
            (_ get-byte)
            (_ (get-comment)))
         #true)))

(define get-whitespace
   (get-any-of
      (get-byte-if (lambda (x) (has? '(#\tab #\newline #\space #\return) x))) ; whitespace
      (let-parses ( ; comment
            (_ (get-imm #\/))
            (_ (get-imm #\*))
            (_ (get-comment)))
         #true)))

(define get-operator
   (let-parses (
         (operator (get-any-of
            (get-word "||" 'Op_or)
            (get-word "&&" 'Op_and)
            (get-word "!=" 'Op_notequal)
            (get-word "==" 'Op_equal)
            (get-word ">=" 'Op_greaterequal)
            (get-word "<=" 'Op_lessequal)

            (get-word "=" 'Op_assign)
            (get-word "!" 'Op_nop)
            (get-word ">" 'Op_greater)
            (get-word "<" 'Op_less)
            (get-word "-" 'Op_subtract)
            (get-word "+" 'Op_add)
            (get-word "%" 'Op_mod)
            (get-word "/" 'Op_divide)
            (get-word "*" 'Op_multiply))))
      (cons 'operator operator)))

(define get-symbol
   (let-parses (
         (symbol (get-any-of
            (get-word "(" 'LeftParen)
            (get-word ")" 'RightParen)
            (get-word "{" 'LeftBrace)
            (get-word "}" 'RightBrace)
            (get-word ";" 'Semicolon)
            (get-word "," 'Comma))))
      (cons 'symbol symbol)))

(define get-keyword
   (let-parses (
         (keyword (get-any-of
            (get-word "if" 'Keyword_if)
            (get-word "else" 'Keyword_else)
            (get-word "while" 'Keyword_while)
            (get-word "print" 'Keyword_print)
            (get-word "putc" 'Keyword_putc))))
      (cons 'keyword keyword)))

(define get-identifier
   (let-parses (
         (lead (get-byte-if              (lambda (x) (or (<= #\a x #\z) (<= #\A x #\Z) (= x #\_)))))
         (tail (get-greedy* (get-byte-if (lambda (x) (or (<= #\a x #\z) (<= #\A x #\Z) (= x #\_) (<= #\0 x #\9)))))))
      (cons 'identifier (bytes->string (cons lead tail)))))

(define get-integer
   (let-parses (
         (main (get-greedy+ (get-byte-if (lambda (x) (<= #\0 x #\9))))) )
      (cons 'integer (string->integer (bytes->string main)))))

(define get-character
   (let-parses (
         (_ (get-imm #\'))
         (char (get-any-of
            (get-word "\\n" #\newline)
            (get-word "\\\\" #\\)
            (get-byte-if (lambda (x) (not (or (eq? x #\') (eq? x #\newline)))))))
         (_ (get-imm #\')) )
      (cons 'character char)))

(define get-string
   (let-parses (
         (_ (get-imm #\")) ;"
         (data (get-greedy* (get-any-of
            (get-word "\\n" #\newline)
            (get-word "\\\\" #\\) ;\"
            (get-byte-if (lambda (x) (not (or (eq? x #\") (eq? x #\newline)))))))) ;", newline
         (_ (get-imm #\")) ) ;"
      (cons 'string (bytes->string data))))

(define get-token
   (let-parses (
         (_ (get-greedy* get-whitespace))
         (token (get-any-of
            get-symbol
            get-keyword
            get-identifier
            get-operator
            get-integer
            get-character
            get-string
         )) )
      token))

(define token-parser
   (let-parses (
         (tokens (get-greedy+ get-token))
         (_ (get-greedy* get-whitespace)))
      tokens))

(define (translate source)
   (let ((stream (try-parse token-parser (str-iter source) #t)))
      (for-each print (car stream))
      (if (null? (cdr stream))
         (print 'End_of_input))))


--
-- demo\rosetta\Compiler\core.e
-- ============================
--
--  Standard declarations and routines used by lex.exw, parse.exw, cgen.exw, and interp.exw
--  (included in distribution as above, which contains some additional sanity checks)
--
with javascript_semantics
global constant EOF = -1, STDIN = 0, STDOUT = 1

global enum NONE=0, UNARY=1, BINARY=2
global type nary(integer n) return n=NONE or n=UNARY or n=BINARY end type

global sequence tkNames = {}    -- eg/ie {"Op_multiply","Op_divide",..}
global sequence precedences = {}
global sequence narys = {}  -- NONE/UNARY/BINARY
global sequence operators = {} -- eg/ie {"*","/","+","-","<","<=",..}
global sequence opcodes = {}    -- idx to tkNames, matching operators

global constant KEYWORDS = new_dict()   -- eg/ie {"if"=>idx to tkNames}

global enum OPERATOR=1, DIGIT, LETTER   -- character classes

global sequence charmap = repeat(0,255)
                charmap['0'..'9'] = DIGIT
                charmap['A'..'Z'] = LETTER
                charmap['a'..'z'] = LETTER
                charmap['_'] = LETTER

function tkName(string s, nary n = NONE, integer precedence = -1)
    tkNames = append(tkNames,s)
    narys = append(narys,n)
    precedences = append(precedences,precedence)
    return length(tkNames)
end function

function tkOp(string s, string op, nary n, integer precedence)
    integer res = tkName(s, n, precedence)
    operators = append(operators,op)
    opcodes = append(opcodes,res)
    for i=1 to length(op) do
        charmap[op[i]] = OPERATOR
    end for
    return res
end function

function tkKw(string s, string keyword)
    integer res = tkName(s)
    putd(keyword, res, KEYWORDS)
    return res
end function

global constant
    tk_EOI           = tkName("End_of_input"),                      --1
    tk_mul           = tkOp("Op_multiply",      "*", BINARY,13),    --2
    tk_div           = tkOp("Op_divide",        "/", BINARY,13),    --3
    tk_mod           = tkOp("Op_mod",           "%", BINARY,13),    --4
    tk_add           = tkOp("Op_add",           "+", BINARY,12),    --5
    tk_sub           = tkOp("Op_subtract",      "-", BINARY,12),    --6
    tk_neg           = tkName("Op_negate",           UNARY, 14),    --7
    tk_not           = tkOp("Op_not",           "!", UNARY, 14),    --8
    tk_lt            = tkOp("Op_less",          "<", BINARY,10),    --9
    tk_le            = tkOp("Op_lessequal",     "<=",BINARY,10),    --10
    tk_gt            = tkOp("Op_greater",       ">", BINARY,10),    --11
    tk_ge            = tkOp("Op_greaterequal",  ">=",BINARY,10),    --12
    tk_eq            = tkOp("Op_equal",         "==",BINARY, 9),    --13
    tk_ne            = tkOp("Op_notequal",      "!=",BINARY, 9),    --14
    tk_assign        = tkOp("Op_assign",        "=", NONE,  -1),    --15
    tk_and           = tkOp("Op_and",           "&&",BINARY, 5),    --16
    tk_or            = tkOp("Op_or",            "||",BINARY, 4),    --17
    tk_if            = tkKw("Keyword_if",   "if"),                  --18
    tk_else          = tkKw("Keyword_else", "else"),                --19
    tk_while         = tkKw("Keyword_while","while"),               --20
    tk_print         = tkKw("Keyword_print","print"),               --21
    tk_putc          = tkKw("Keyword_putc", "putc"),                --22
    tk_LeftParen     = tkOp("LeftParen",        "(", NONE,  -1),    --23
    tk_RightParen    = tkOp("RightParen",       ")", NONE,  -1),    --24
    tk_LeftBrace     = tkOp("LeftBrace",        "{", NONE,  -1),    --25
    tk_RightBrace    = tkOp("RightBrace",       "}", NONE,  -1),    --26
    tk_Semicolon     = tkOp("Semicolon",        ";", NONE,  -1),    --27
    tk_Comma         = tkOp("Comma",            ",", NONE,  -1),    --28
    tk_Identifier    = tkName("Identifier"),                        --29
    tk_Integer       = tkName("Integer"),                           --30
    tk_String        = tkName("String"),                            --31
    tk_Sequence      = tkName("Sequence"),                          --32
    tk_Prints        = tkName("tk_Prints"),                         --33
    tk_Printi        = tkName("tk_Printi")                          --34

global integer input_file = STDIN,
               output_file = STDOUT

type strint(object o)
    return string(o) or integer(o)
end type

global strint tok_line, -- save of line/col at the start of
              tok_col   -- token/comment, for result/errors

global object oneline = ""

constant errfmt = "Line %s column %s:\n%s%s"

function errline()
    oneline = substitute(trim(oneline,"\r\n"),'\t',' ')
    string padding = repeat(' ',tok_col)
    return sprintf("%s\n%s^ ",{oneline,padding})
end function

global procedure error(sequence msg, sequence args={})
    if length(args) then
        msg = sprintf(msg,args)
    end if
    string el = iff(atom(oneline)?"":errline())
    if integer(tok_line) then tok_line = sprintf("%d",tok_line) end if
    if integer(tok_col) then tok_col = sprintf("%d",tok_col) end if
    printf(STDOUT,errfmt,{tok_line,tok_col,el,msg})
    {} = wait_key()
    abort(1)
end procedure

include js_io.e -- fake file i/o for running under pwa/p2js

function open_file(string file_name, string mode)
    integer fn = iff(platform()=JS?js_open(file_name)
                                  :open(file_name, mode))
    if fn<=0 then
        printf(STDOUT, "Could not open %s", {file_name})
        {} = wait_key()
        abort(1)
    end if
    return fn
end function

global procedure open_files(sequence cl)
    if length(cl)>2 then
        input_file = open_file(cl[3],"r")
        if length(cl)>3 then
            output_file = open_file(cl[4],"w")
        end if
    end if
end procedure

global procedure close_files()
    if platform()!=JS then
        if input_file!=STDIN then close(input_file) end if
        if output_file!=STDOUT then close(output_file) end if
    end if
end procedure

global function enquote(string s)
    return sprintf(`"%s"`,substitute(s,"\n","\\n"))
end function

global function unquote(string s)
    if s[1]!='\"' then ?9/0 end if
    if s[$]!='\"' then ?9/0 end if
    s = substitute(s[2..-2],"\\n","\n")
    return s
end function


/*
    Test harness for the analyzer, not needed if we are actually using the output.
*/
load_file(File, Input) :-
	read_file_to_codes(File, Codes, []),
	maplist(char_code, Chars, Codes),
	atom_chars(Input,Chars).

test_file(File) :-
	load_file(File, Input),
	tester(Input).

tester(S) :-
	atom_chars(S,Chars),
	tokenize(Chars,L),
	maplist(print_tok, L),
	!.

print_tok(L) :-
	L =.. [Op,Line,Pos],
	format('~d\t~d\t~p~n', [Line,Pos,Op]).
print_tok(string(Value,Line,Pos)) :-
	format('~d\t~d\tstring\t\t"~w"~n', [Line,Pos,Value]).
print_tok(identifier(Value,Line,Pos)) :-
	format('~d\t~d\tidentifier\t~p~n', [Line,Pos,Value]).
print_tok(integer(Value,Line,Pos)) :-
	format('~d\t~d\tinteger\t\t~p~n', [Line,Pos,Value]).

/*
	Tokenize

	run the input over a DCG to get out the tokens.

	In - a list of chars to tokenize
	Tokens = a list of tokens (excluding spaces).
*/
tokenize(In,RelTokens) :-
	newline_positions(In,1,NewLines),
	tokenize(In,[0|NewLines],1,1,Tokens),
	check_for_exceptions(Tokens),
	exclude(token_name(space),Tokens,RelTokens).

tokenize([],NewLines,Pos,LineNo,[end_of_input(LineNo,Offset)]) :-
	position_offset(NewLines,Pos,Offset).
tokenize(In,NewLines,Pos,LineNo,Out) :-
	position_offset(NewLines,Pos,Offset),
	phrase(tok(Tok,TokLen,LineNo,Offset),In,T),
	(
		Tok = [] -> Out = Toks
		; Out = [Tok|Toks]
	),
	Pos1 is Pos + TokLen,
	update_line_no(LineNo,NewLines,Pos1,NewLineNo,NewNewLines),
	tokenize(T,NewNewLines,Pos1,NewLineNo,Toks).

update_line_no(LNo,[L],_,LNo,[L]).
update_line_no(LNo,[L,Nl|T],Pos,LNo,[L,Nl|T]) :-
	Pos =< Nl.
update_line_no(LNo,[_,Nl|T],Pos,LNo2,Nlines) :-
	Pos > Nl,
	succ(LNo,LNo1),
	update_line_no(LNo1,[Nl|T],Pos,LNo2,Nlines).

position_offset([Line|_],Pos,Offset) :- Offset is Pos - Line.

token_name(Name,Tok) :- functor(Tok,Name,_).

% Get a list of all the newlines and their position in the data
% This is used to create accurate row/column numbers.
newline_positions([],N,[N]).
newline_positions(['\n'|T],N,[N|Nt]) :- succ(N,N1), newline_positions(T,N1,Nt).
newline_positions([C|T],N,Nt) :- dif(C,'\n'), succ(N,N1), newline_positions(T,N1,Nt).

% The tokenizer can tokenize some things that it shouldn't, deal with them here.
check_for_exceptions([]). % all ok
check_for_exceptions([op_divide(L,P),op_multiply(_,_)|_]) :-
	format(atom(Error), 'Unclosed comment at line ~d,~d', [L,P]),
	throw(Error).
check_for_exceptions([integer(_,L,P),identifier(_,_,_)|_]) :-
	format(atom(Error), 'Invalid identifier at line ~d,~d', [L,P]),
	throw(Error).
check_for_exceptions([_|T]) :- check_for_exceptions(T).

/*
	A set of helper DCGs for the more complicated token types
*/
:- set_prolog_flag(double_quotes, chars).

identifier(I) --> c_types(I,csym).
identifier(['_']) --> ['_'].
identifier([]) --> [].

integer_(I,L) --> c_types(N,digit), { number_codes(I,N), length(N,L) }.

% get a sequence of characters of the same type (https://www.swi-prolog.org/pldoc/doc_for?object=char_type/2)
c_types([C|T],Type) --> c_type(C,Type), c_types(T,Type).
c_types([C],Type) --> c_type(C,Type).
c_type(C,Type) --> [C],{ char_type(C,Type) }.

anything([]) --> [].
anything([A|T]) --> [A], anything(T).

string_([]) --> [].
string_([A|T]) --> [A], { dif(A,'\n') }, string_(T).

/*
	The token types are all handled by the tok DCG, order of predicates is important here.
*/
% comment
tok([],CLen,_,_) --> "/*", anything(A), "*/", { length(A,Len), CLen is Len + 4 }.

% toks
tok(op_and(L,P),2,L,P) --> "&&".
tok(op_or(L,P),2,L,P) --> "||".
tok(op_lessequal(L,P),2,L,P) --> "<=".
tok(op_greaterequal(L,P),2,L,P) --> ">=".
tok(op_greaterequal(L,P),2,L,P) --> ">=".
tok(op_equal(L,P),2,L,P) --> "==".
tok(op_notequal(L,P),2,L,P) --> "!=".
tok(op_assign(L,P),1,L,P) --> "=".
tok(op_multiply(L,P),1,L,P) --> "*".
tok(op_divide(L,P),1,L,P) --> "/".
tok(op_mod(L,P),1,L,P) --> "%".
tok(op_add(L,P),1,L,P) --> "+".
tok(op_subtract(L,P),1,L,P) --> "-".
tok(op_negate(L,P),1,L,P) --> "-".
tok(op_less(L,P),1,L,P) --> "<".
tok(op_greater(L,P),1,L,P) --> ">".
tok(op_not(L,P),1,L,P) --> "!".

% symbols
tok(left_paren(L,P),1,L,P) --> "(".
tok(right_paren(L,P),1,L,P) --> ")".
tok(left_brace(L,P),1,L,P) --> "{".
tok(right_brace(L,P),1,L,P) --> "}".
tok(semicolon(L,P),1,L,P) --> ";".
tok(comma(L,P),1,L,P) --> ",".

% keywords
tok(keyword_if(L,P),2,L,P) --> "if".
tok(keyword_else(L,P),4,L,P) --> "else".
tok(keyword_while(L,P),5,L,P) --> "while".
tok(keyword_print(L,P),5,L,P) --> "print".
tok(keyword_putc(L,P),4,L,P) --> "putc".

% identifier and literals
tok(identifier(I,L,P),Len,L,P) --> c_type(S,csymf), identifier(T), { atom_chars(I,[S|T]), length([S|T],Len) }.
tok(integer(V,L,P),Len,L,P) --> integer_(V,Len).
tok(integer(I,L,P),4,L,P) --> "'\\\\'", { char_code('\\', I) }.
tok(integer(I,L,P),4,L,P) --> "'\\n'", { char_code('\n', I) }.
tok(integer(I,L,P),3,L,P) --> ['\''], [C], ['\''], { dif(C,'\n'), dif(C,'\''), char_code(C,I) }.
tok(string(S,L,P),SLen,L,P) --> ['"'], string_(A),['"'], { atom_chars(S,A), length(A,Len), SLen is Len + 2 }.

% spaces
tok(space(L,P),Len,L,P) --> c_types(S,space), { length(S,Len) }.

% anything else is an error
tok(_,_,L,P) --> { format(atom(Error), 'Invalid token at line ~d,~d', [L,P]), throw(Error) }.


from __future__ import print_function
import sys

# following two must remain in the same order

tk_EOI, tk_Mul, tk_Div, tk_Mod, tk_Add, tk_Sub, tk_Negate, tk_Not, tk_Lss, tk_Leq, tk_Gtr, \
tk_Geq, tk_Eq, tk_Neq, tk_Assign, tk_And, tk_Or, tk_If, tk_Else, tk_While, tk_Print,       \
tk_Putc, tk_Lparen, tk_Rparen, tk_Lbrace, tk_Rbrace, tk_Semi, tk_Comma, tk_Ident,          \
tk_Integer, tk_String = range(31)

all_syms = ["End_of_input", "Op_multiply", "Op_divide", "Op_mod", "Op_add", "Op_subtract",
    "Op_negate", "Op_not", "Op_less", "Op_lessequal", "Op_greater", "Op_greaterequal",
    "Op_equal", "Op_notequal", "Op_assign", "Op_and", "Op_or", "Keyword_if",
    "Keyword_else", "Keyword_while", "Keyword_print", "Keyword_putc", "LeftParen",
    "RightParen", "LeftBrace", "RightBrace", "Semicolon", "Comma", "Identifier",
    "Integer", "String"]

# single character only symbols
symbols = { '{': tk_Lbrace, '}': tk_Rbrace, '(': tk_Lparen, ')': tk_Rparen, '+': tk_Add, '-': tk_Sub,
    '*': tk_Mul, '%': tk_Mod, ';': tk_Semi, ',': tk_Comma }

key_words = {'if': tk_If, 'else': tk_Else, 'print': tk_Print, 'putc': tk_Putc, 'while': tk_While}

the_ch = " "    # dummy first char - but it must be a space
the_col = 0
the_line = 1
input_file = None

#*** show error and exit
def error(line, col, msg):
    print(line, col, msg)
    exit(1)

#*** get the next character from the input
def next_ch():
    global the_ch, the_col, the_line

    the_ch = input_file.read(1)
    the_col += 1
    if the_ch == '\n':
        the_line += 1
        the_col = 0
    return the_ch

#*** 'x' - character constants
def char_lit(err_line, err_col):
    n = ord(next_ch())              # skip opening quote
    if the_ch == '\'':
        error(err_line, err_col, "empty character constant")
    elif the_ch == '\\':
        next_ch()
        if the_ch == 'n':
            n = 10
        elif the_ch == '\\':
            n = ord('\\')
        else:
            error(err_line, err_col, "unknown escape sequence \\%c" % (the_ch))
    if next_ch() != '\'':
        error(err_line, err_col, "multi-character constant")
    next_ch()
    return tk_Integer, err_line, err_col, n

#*** process divide or comments
def div_or_cmt(err_line, err_col):
    if next_ch() != '*':
        return tk_Div, err_line, err_col

    # comment found
    next_ch()
    while True:
        if the_ch == '*':
            if next_ch() == '/':
                next_ch()
                return gettok()
        elif len(the_ch) == 0:
            error(err_line, err_col, "EOF in comment")
        else:
            next_ch()

#*** "string"
def string_lit(start, err_line, err_col):
    global the_ch
    text = ""

    while next_ch() != start:
        if len(the_ch) == 0:
            error(err_line, err_col, "EOF while scanning string literal")
        if the_ch == '\n':
            error(err_line, err_col, "EOL while scanning string literal")
        if the_ch == '\\':
            next_ch()
            if the_ch != 'n':
                error(err_line, err_col, "escape sequence unknown \\%c" % the_ch)
            the_ch = '\n'
        text += the_ch

    next_ch()
    return tk_String, err_line, err_col, text

#*** handle identifiers and integers
def ident_or_int(err_line, err_col):
    is_number = True
    text = ""

    while the_ch.isalnum() or the_ch == '_':
        text += the_ch
        if not the_ch.isdigit():
            is_number = False
        next_ch()

    if len(text) == 0:
        error(err_line, err_col, "ident_or_int: unrecognized character: (%d) '%c'" % (ord(the_ch), the_ch))

    if text[0].isdigit():
        if not is_number:
            error(err_line, err_col, "invalid number: %s" % (text))
        n = int(text)
        return tk_Integer, err_line, err_col, n

    if text in key_words:
        return key_words[text], err_line, err_col

    return tk_Ident, err_line, err_col, text

#*** look ahead for '>=', etc.
def follow(expect, ifyes, ifno, err_line, err_col):
    if next_ch() == expect:
        next_ch()
        return ifyes, err_line, err_col

    if ifno == tk_EOI:
        error(err_line, err_col, "follow: unrecognized character: (%d) '%c'" % (ord(the_ch), the_ch))

    return ifno, err_line, err_col

#*** return the next token type
def gettok():
    while the_ch.isspace():
        next_ch()

    err_line = the_line
    err_col  = the_col

    if len(the_ch) == 0:    return tk_EOI, err_line, err_col
    elif the_ch == '/':     return div_or_cmt(err_line, err_col)
    elif the_ch == '\'':    return char_lit(err_line, err_col)
    elif the_ch == '<':     return follow('=', tk_Leq, tk_Lss,    err_line, err_col)
    elif the_ch == '>':     return follow('=', tk_Geq, tk_Gtr,    err_line, err_col)
    elif the_ch == '=':     return follow('=', tk_Eq,  tk_Assign, err_line, err_col)
    elif the_ch == '!':     return follow('=', tk_Neq, tk_Not,    err_line, err_col)
    elif the_ch == '&':     return follow('&', tk_And, tk_EOI,    err_line, err_col)
    elif the_ch == '|':     return follow('|', tk_Or,  tk_EOI,    err_line, err_col)
    elif the_ch == '"':     return string_lit(the_ch, err_line, err_col)
    elif the_ch in symbols:
        sym = symbols[the_ch]
        next_ch()
        return sym, err_line, err_col
    else: return ident_or_int(err_line, err_col)

#*** main driver
input_file = sys.stdin
if len(sys.argv) > 1:
    try:
        input_file = open(sys.argv[1], "r", 4096)
    except IOError as e:
        error(0, 0, "Can't open %s" % sys.argv[1])

while True:
    t = gettok()
    tok  = t[0]
    line = t[1]
    col  = t[2]

    print("%5d  %5d   %-14s" % (line, col, all_syms[tok]), end='')

    if tok == tk_Integer:  print("   %5d" % (t[3]))
    elif tok == tk_Ident:  print("  %s" %   (t[3]))
    elif tok == tk_String: print('  "%s"' % (t[3]))
    else:                  print("")

    if tok == tk_EOI:
        break


dim shared source as string, the_ch as string, tok as string, toktyp as string
dim shared line_n as integer, col_n as integer, text_p as integer, err_line as integer, err_col as integer, errors as integer

declare function isalnum&(s as string)
declare function isalpha&(s as string)
declare function isdigit&(s as string)
declare sub divide_or_comment
declare sub error_exit(line_n as integer, col_n as integer, msg as string)
declare sub follow(c as string, typ2 as string, typ1 as string)
declare sub nextch
declare sub nexttok
declare sub read_char_lit
declare sub read_ident
declare sub read_number
declare sub read_string

const c_integer = "Integer", c_ident = "Identifier", c_string = "String"

dim out_fn as string, out_tok as string

if command$(1) = "" then print "Expecting a filename": end
open command$(1) for binary as #1
source = space$(lof(1))
get #1, 1, source
close #1

out_fn = command$(2): if out_fn <> "" then open out_fn for output as #1

line_n = 1: col_n = 0: text_p = 1: the_ch = " "

do
    call nexttok
    select case toktyp
        case c_integer, c_ident, c_string: out_tok = tok
        case else:                         out_tok = ""
    end select
    if out_fn = "" then
        print err_line, err_col, toktyp, out_tok
    else
        print #1, err_line, err_col, toktyp, out_tok
    end if
loop until errors or tok = ""
if out_fn <> "" then close #1
end

' get next tok, toktyp
sub nexttok
    toktyp = ""
    restart: err_line = line_n: err_col = col_n: tok = the_ch
    select case the_ch
        case " ", chr$(9), chr$(10): call nextch:          goto restart
        case "/": call divide_or_comment: if tok = "" then goto restart

        case "%": call nextch: toktyp = "Op_mod"
        case "(": call nextch: toktyp = "LeftParen"
        case ")": call nextch: toktyp = "RightParen"
        case "*": call nextch: toktyp = "Op_multiply"
        case "+": call nextch: toktyp = "Op_add"
        case ",": call nextch: toktyp = "Comma"
        case "-": call nextch: toktyp = "Op_subtract"
        case ";": call nextch: toktyp = "Semicolon"
        case "{": call nextch: toktyp = "LeftBrace"
        case "}": call nextch: toktyp = "RightBrace"

        case "&": call follow("&", "Op_and",          "")
        case "|": call follow("|", "Op_or",           "")
        case "!": call follow("=", "Op_notequal",     "Op_not")
        case "<": call follow("=", "Op_lessequal",    "Op_less")
        case "=": call follow("=", "Op_equal",        "Op_assign")
        case ">": call follow("=", "Op_greaterequal", "Op_greater")

        case chr$(34): call read_string
        case chr$(39): call read_char_lit

        case "": toktyp = "End_of_input"

        case else
            if isdigit&(the_ch) then
                call read_number
            elseif isalpha&(the_ch) then
                call read_ident
            else
                call nextch
            end if
    end select
end sub

sub follow(c as string, if_both as string, if_one as string)
    call nextch
    if the_ch = c then
        tok = tok + the_ch
        call nextch
        toktyp = if_both
    else
        if if_one = "" then call error_exit(line_n, col_n, "Expecting " + c): exit sub
        toktyp = if_one
    end if
end sub

sub read_string
    toktyp = c_string
    call nextch
    do
        tok = tok + the_ch
        select case the_ch
            case chr$(10): call error_exit(line_n, col_n, "EOL in string"): exit sub
            case "":       call error_exit(line_n, col_n, "EOF in string"): exit sub
            case chr$(34): call nextch: exit sub
            case else:     call nextch
        end select
    loop
end sub

sub read_char_lit
    toktyp = c_integer
    call nextch
    if the_ch = chr$(39) then
        call error_exit(err_line, err_col, "Empty character constant"): exit sub
    end if

    if the_ch = "\" then
        call nextch
        if the_ch = "n" then
            tok = "10"
        elseif the_ch = "\" then
            tok = "92"
        else
            call error_exit(line_n, col_n, "Unknown escape sequence:" + the_ch): exit sub
        end if
    else
        tok = ltrim$(str$(asc(the_ch)))
    end if

    call nextch
    if the_ch <> chr$(39) then
        call error_exit(line_n, col_n, "Multi-character constant"): exit sub
    end if
    call nextch
end sub

sub divide_or_comment
    call nextch
    if the_ch <> "*" then
        toktyp = "Op_divide"
    else  ' skip comments
        tok = ""
        call nextch
        do
            if the_ch = "*" then
                call nextch
                if the_ch = "/" then
                    call nextch
                    exit sub
                end if
            elseif the_ch = "" then
                call error_exit(line_n, col_n, "EOF in comment"): exit sub
            else
                call nextch
            end if
        loop
    end if
end sub

sub read_ident
    do
        call nextch
        if not isalnum&(the_ch) then exit do
        tok = tok + the_ch
    loop
    select case tok
        case "else":  toktyp = "keyword_else"
        case "if":    toktyp = "keyword_if"
        case "print": toktyp = "keyword_print"
        case "putc":: toktyp = "keyword_putc"
        case "while": toktyp = "keyword_while"
        case else:    toktyp = c_ident
    end select
end sub

sub read_number
    toktyp = c_integer
    do
        call nextch
        if not isdigit&(the_ch) then exit do
        tok = tok + the_ch
    loop

    if isalpha&(the_ch) then
        call error_exit(err_line, err_col, "Bogus number: " + tok + the_ch): exit sub
    end if
end sub

function isalpha&(s as string)
  dim c as string
  c = left$(s, 1)
  isalpha& = c <> "" and instr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_", c) > 0
end function

function isdigit&(s as string)
  dim c as string
  c = left$(s, 1)
  isdigit& = c <> "" and instr("0123456789", c) > 0
end function

function isalnum&(s as string)
  dim c as string
  c = left$(s, 1)
  isalnum& = c <> "" and instr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_", c) > 0
end function

' get next char - fold cr/lf into just lf
sub nextch
    the_ch = ""
    col_n = col_n + 1
    if text_p > len(source) then exit sub

    the_ch = mid$(source, text_p, 1)
    text_p = text_p + 1

    if the_ch = chr$(13) then
        the_ch = chr$(10)
        if text_p <= len(source) then
            if mid$(source, text_p, 1) = chr$(10) then
                text_p = text_p + 1
            end if
        end if
    end if

    if the_ch = chr$(10) then
        line_n = line_n + 1
        col_n = 0
    end if

end sub

sub error_exit(line_n as integer, col_n as integer, msg as string)
    errors = -1
    print line_n, col_n, msg
    end
end sub


#lang racket
(require parser-tools/lex)

(define-lex-abbrevs
  [letter         (union (char-range #\a #\z) (char-range #\A #\Z))]
  [digit          (char-range #\0 #\9)]
  [underscore     #\_]
  [identifier     (concatenation (union letter underscore)
                                 (repetition 0 +inf.0 (union letter digit underscore)))]
  [integer        (repetition 1 +inf.0 digit)]
  [char-content   (char-complement (char-set "'\n"))]
  [char-literal   (union (concatenation #\' char-content #\')
                         "'\\n'" "'\\\\'")]
  [string-content (union (char-complement (char-set "\"\n")))]
  [string-literal (union (concatenation #\" (repetition 0 +inf.0 string-content) #\")
                         "\"\\n\"" "\"\\\\\"")]
  [keyword        (union "if" "else" "while" "print" "putc")]
  [operator       (union "*" "/" "%" "+" "-" "-"
                         "<" "<=" ">" ">=" "==" "!="
                         "!" "=" "&&" "||")]
  [symbol         (union "(" ")" "{" "}" ";" ",")]
  [comment        (concatenation "/*" (complement (concatenation any-string "*/" any-string)) "*/")])

(define operators-ht
  (hash "*"  'Op_multiply "/"  'Op_divide    "%" 'Op_mod      "+"  'Op_add           "-"  'Op_subtract
        "<"  'Op_less     "<=" 'Op_lessequal ">" 'Op_greater  ">=" 'Op_greaterequal "==" 'Op_equal
        "!=" 'Op_notequal "!"  'Op_not       "=" 'Op_assign   "&&" 'Op_and          "||" 'Op_or))

(define symbols-ht
  (hash "(" 'LeftParen  ")" 'RightParen
        "{" 'LeftBrace  "}" 'RightBrace
        ";" 'Semicolon  "," 'Comma))

(define (lexeme->keyword  l) (string->symbol (~a "Keyword_" l)))
(define (lexeme->operator l) (hash-ref operators-ht l))
(define (lexeme->symbol   l) (hash-ref symbols-ht   l))
(define (lexeme->char     l) (match l
                               ["'\\\\'" #\\]
                               ["'\\n'"  #\newline]
                               [_       (string-ref l 1)]))

(define (token name [value #f])
  (cons name (if value (list value) '())))

(define (lex ip)
  (port-count-lines! ip)
  (define my-lexer
    (lexer-src-pos
     [integer        (token 'Integer (string->number lexeme))]
     [char-literal   (token 'Integer (char->integer (lexeme->char lexeme)))]
     [string-literal (token 'String  lexeme)]
     [keyword        (token (lexeme->keyword  lexeme))]
     [operator       (token (lexeme->operator lexeme))]
     [symbol         (token (lexeme->symbol   lexeme))]
     [comment        #f]
     [whitespace     #f]
     [identifier     (token 'Identifier lexeme)]
     [(eof)          (token 'End_of_input)]))
  (define (next-token) (my-lexer ip))
  next-token)

(define (string->tokens s)
  (port->tokens (open-input-string s)))

(define (port->tokens ip)
  (define next-token (lex ip))
  (let loop ()
    (match (next-token)
      [(position-token t (position offset line col) _)
       (set! col (+ col 1)) ; output is 1-based
       (match t
         [#f                   (loop)] ; skip whitespace/comments
         [(list 'End_of_input) (list (list line col 'End_of_input))]
         [(list name value)    (cons (list line col name value) (loop))]
         [(list name)          (cons (list line col name)       (loop))]
         [_ (error)])])))

(define test1 #<<TEST
/*
  Hello world
 */
print("Hello, World!\n");

TEST
)

(define test2 #<<TEST
/*
  Show Ident and Integers
 */
phoenix_number = 142857;
print(phoenix_number, "\n");

TEST
  )

(define test3 #<<TEST
/*
  All lexical tokens - not syntactically correct, but that will
  have to wait until syntax analysis
 */
/* Print   */  print    /* Sub     */  -
/* Putc    */  putc     /* Lss     */  <
/* If      */  if       /* Gtr     */  >
/* Else    */  else     /* Leq     */  <=
/* While   */  while    /* Geq     */  >=
/* Lbrace  */  {        /* Eq      */  ==
/* Rbrace  */  }        /* Neq     */  !=
/* Lparen  */  (        /* And     */  &&
/* Rparen  */  )        /* Or      */  ||
/* Uminus  */  -        /* Semi    */  ;
/* Not     */  !        /* Comma   */  ,
/* Mul     */  *        /* Assign  */  =
/* Div     */  /        /* Integer */  42
/* Mod     */  %        /* String  */  "String literal"
/* Add     */  +        /* Ident   */  variable_name
/* character literal */  '\n'
/* character literal */  '\\'
/* character literal */  ' '
TEST
  )

(define test4 #<<TEST
/*** test printing, embedded \n and comments with lots of '*' ***/
print(42);
print("\nHello World\nGood Bye\nok\n");
print("Print a slash n - \\n.\n");
TEST
  )

(define test5 #<<TEST
count = 1;
while (count < 10) {
    print("count is: ", count, "\n");
    count = count + 1;
}
TEST
  )

(define (display-tokens ts)
  (for ([t ts])
    (for ([x t])
      (display x) (display "\t\t"))
    (newline)))

"TEST 1"
(display-tokens (string->tokens test1))
"TEST 2"
(display-tokens (string->tokens test2))
"TEST 3"
(display-tokens (string->tokens test3))
"TEST 4"
(display-tokens (string->tokens test4))
"TEST 5"
(display-tokens (string->tokens test5))


grammar tiny_C {
    rule TOP { ^ <.whitespace>? <tokens> + % <.whitespace> <.whitespace> <eoi> }

    rule whitespace { [ <comment> + % <ws> | <ws> ] }

    token comment    { '/*' ~ '*/' .*? }

    token tokens {
        [
        | <operator>   { make $/<operator>.ast   }
        | <keyword>    { make $/<keyword>.ast    }
        | <symbol>     { make $/<symbol>.ast     }
        | <identifier> { make $/<identifier>.ast }
        | <integer>    { make $/<integer>.ast    }
        | <char>       { make $/<char>.ast       }
        | <string>     { make $/<string>.ast     }
        | <error>
        ]
    }

    proto token operator    {*}
    token operator:sym<*>   { '*'               { make 'Op_multiply'    } }
    token operator:sym</>   { '/'<!before '*'>  { make 'Op_divide'      } }
    token operator:sym<%>   { '%'               { make 'Op_mod'         } }
    token operator:sym<+>   { '+'               { make 'Op_add'         } }
    token operator:sym<->   { '-'               { make 'Op_subtract'    } }
    token operator:sym('<='){ '<='              { make 'Op_lessequal'   } }
    token operator:sym('<') { '<'               { make 'Op_less'        } }
    token operator:sym('>='){ '>='              { make 'Op_greaterequal'} }
    token operator:sym('>') { '>'               { make 'Op_greater'     } }
    token operator:sym<==>  { '=='              { make 'Op_equal'       } }
    token operator:sym<!=>  { '!='              { make 'Op_notequal'    } }
    token operator:sym<!>   { '!'               { make 'Op_not'         } }
    token operator:sym<=>   { '='               { make 'Op_assign'      } }
    token operator:sym<&&>  { '&&'              { make 'Op_and'         } }
    token operator:sym<||>  { '||'              { make 'Op_or'          } }

    proto token keyword      {*}
    token keyword:sym<if>    { 'if'    { make 'Keyword_if'    } }
    token keyword:sym<else>  { 'else'  { make 'Keyword_else'  } }
    token keyword:sym<putc>  { 'putc'  { make 'Keyword_putc'  } }
    token keyword:sym<while> { 'while' { make 'Keyword_while' } }
    token keyword:sym<print> { 'print' { make 'Keyword_print' } }

    proto token symbol  {*}
    token symbol:sym<(> { '(' { make 'LeftParen'  } }
    token symbol:sym<)> { ')' { make 'RightParen' } }
    token symbol:sym<{> { '{' { make 'LeftBrace'  } }
    token symbol:sym<}> { '}' { make 'RightBrace' } }
    token symbol:sym<;> { ';' { make 'Semicolon'   } }
    token symbol:sym<,> { ',' { make 'Comma'       } }

    token identifier { <[_A..Za..z]><[_A..Za..z0..9]>* { make 'Identifier ' ~ $/ } }
    token integer    { <[0..9]>+                       { make 'Integer '    ~ $/ } }

    token char {
        '\'' [<-[']> | '\n' | '\\\\'] '\''
        { make 'Char_Literal ' ~ $/.subst("\\n", "\n").substr(1, *-1).ord }
    }

    token string {
        '"' <-["\n]>* '"' #'
        {
            make 'String ' ~ $/;
            note 'Error: Unknown escape sequence.' and exit if (~$/ ~~ m:r/ <!after <[\\]>>[\\<-[n\\]>]<!before <[\\]>> /);
        }
    }

    token eoi { $ { make 'End_of_input' } }

    token error {
        | '\'''\''                   { note 'Error: Empty character constant.' and exit }
        | '\'' <-[']> ** {2..*} '\'' { note 'Error: Multi-character constant.' and exit }
        | '/*' <-[*]>* $             { note 'Error: End-of-file in comment.'   and exit }
        | '"' <-["]>* $              { note 'Error: End-of-file in string.'    and exit }
        | '"' <-["]>*? \n            { note 'Error: End of line in string.'    and exit } #'
    }
}

sub parse_it ( $c_code ) {
    my $l;
    my @pos = gather for $c_code.lines>>.chars.kv -> $line, $v {
        take [ $line + 1, $_ ] for 1 .. ($v+1); # v+1 for newline
        $l = $line+2;
    }
    @pos.push: [ $l, 1 ]; # capture eoi

    for flat $c_code<tokens>.list, $c_code<eoi> -> $m {
        say join "\t", @pos[$m.from].fmt('%3d'), $m.ast;
    }
}

my $tokenizer = tiny_C.parse(@*ARGS[0].IO.slurp);
parse_it( $tokenizer );