#include <charconv>      // std::from_chars
#include <fstream>       // file_to_string, string_to_file
#include <functional>    // std::invoke
#include <iomanip>       // std::setw
#include <ios>           // std::left
#include <iostream>
#include <map>           // keywords
#include <sstream>
#include <string>
#include <utility>       // std::forward
#include <variant>       // TokenVal

using namespace std;

// =====================================================================================================================
// Machinery
// =====================================================================================================================
string file_to_string (const string& path)
{
    // Open file
    ifstream file {path, ios::in | ios::binary | ios::ate};
    if (!file)   throw (errno);

    // Allocate string memory
    string contents;
    contents.resize(file.tellg());

    // Read file contents into string
    file.seekg(0);
    file.read(contents.data(), contents.size());

    return contents;
}

void string_to_file (const string& path, string contents)
{
    ofstream file {path, ios::out | ios::binary};
    if (!file)    throw (errno);

    file.write(contents.data(), contents.size());
}

template <class F>
void with_IO (string source, string destination, F&& f)
{
    string input;

    if (source == "stdin")    getline(cin, input);
    else                      input = file_to_string(source);

    string output = invoke(forward<F>(f), input);

    if (destination == "stdout")    cout << output;
    else                            string_to_file(destination, output);
}

// Add escaped newlines and backslashes back in for printing
string sanitize (string s)
{
    for (auto i = 0u; i < s.size(); ++i)
    {
        if      (s[i] == '\n')    s.replace(i++, 1, "\\n");
        else if (s[i] == '\\')    s.replace(i++, 1, "\\\\");
    }

    return s;
}

class Scanner
{
public:
    const char* pos;
    int         line   = 1;
    int         column = 1;

    Scanner (const char* source) : pos {source} {}

    inline char peek ()    { return *pos; }

    void advance ()
    {
        if (*pos == '\n')    { ++line; column = 1; }
        else                 ++column;

        ++pos;
    }

    char next ()
    {
        advance();
        return peek();
    }

    void skip_whitespace ()
    {
        while (isspace(static_cast<unsigned char>(peek())))
            advance();
    }
}; // class Scanner

// =====================================================================================================================
// Tokens
// =====================================================================================================================
enum class TokenName
{
    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,
    KEYWORD_IF, KEYWORD_ELSE, KEYWORD_WHILE, KEYWORD_PRINT, KEYWORD_PUTC,
    IDENTIFIER, INTEGER, STRING,
    END_OF_INPUT, ERROR
};

using TokenVal = variant<int, string>;

struct Token
{
    TokenName name;
    TokenVal  value;
    int       line;
    int       column;
};

const char* to_cstring (TokenName name)
{
    static const char* s[] =
    {
        "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",
        "Keyword_if", "Keyword_else", "Keyword_while", "Keyword_print", "Keyword_putc",
        "Identifier", "Integer", "String",
        "End_of_input", "Error"
    };

    return s[static_cast<int>(name)];
}

string to_string (Token t)
{
    ostringstream out;
    out << setw(2) << t.line << "   " << setw(2) << t.column  << "   ";

    switch (t.name)
    {
        case (TokenName::IDENTIFIER)   : out << "Identifier        "   << get<string>(t.value);                  break;
        case (TokenName::INTEGER)      : out << "Integer           "   << left << get<int>(t.value);             break;
        case (TokenName::STRING)       : out << "String            \"" << sanitize(get<string>(t.value)) << '"'; break;
        case (TokenName::END_OF_INPUT) : out << "End_of_input";                                                  break;
        case (TokenName::ERROR)        : out << "Error             "   << get<string>(t.value);                  break;
        default                        : out << to_cstring(t.name);
    }

    out << '\n';

    return out.str();
}

// =====================================================================================================================
// Lexer
// =====================================================================================================================
class Lexer
{
public:
    Lexer (const char* source) : s {source}, pre_state {s} {}

    bool has_more ()    { return s.peek() != '\0'; }

    Token next_token ()
    {
        s.skip_whitespace();

        pre_state = s;

        switch (s.peek())
        {
            case '*'  :    return simply(TokenName::OP_MULTIPLY);
            case '%'  :    return simply(TokenName::OP_MOD);
            case '+'  :    return simply(TokenName::OP_ADD);
            case '-'  :    return simply(TokenName::OP_SUBTRACT);
            case '{'  :    return simply(TokenName::LEFTBRACE);
            case '}'  :    return simply(TokenName::RIGHTBRACE);
            case '('  :    return simply(TokenName::LEFTPAREN);
            case ')'  :    return simply(TokenName::RIGHTPAREN);
            case ';'  :    return simply(TokenName::SEMICOLON);
            case ','  :    return simply(TokenName::COMMA);
            case '&'  :    return expect('&', TokenName::OP_AND);
            case '|'  :    return expect('|', TokenName::OP_OR);
            case '<'  :    return follow('=', TokenName::OP_LESSEQUAL,    TokenName::OP_LESS);
            case '>'  :    return follow('=', TokenName::OP_GREATEREQUAL, TokenName::OP_GREATER);
            case '='  :    return follow('=', TokenName::OP_EQUAL,        TokenName::OP_ASSIGN);
            case '!'  :    return follow('=', TokenName::OP_NOTEQUAL,     TokenName::OP_NOT);
            case '/'  :    return divide_or_comment();
            case '\'' :    return char_lit();
            case '"'  :    return string_lit();

            default   :    if (is_id_start(s.peek()))    return identifier();
                           if (is_digit(s.peek()))       return integer_lit();
                           return error("Unrecognized character '", s.peek(), "'");

            case '\0' :    return make_token(TokenName::END_OF_INPUT);
        }
    }

private:
    Scanner s;
    Scanner pre_state;
    static const map<string, TokenName> keywords;

    template <class... Args>
    Token error (Args&&... ostream_args)
    {
        string code {pre_state.pos, (string::size_type) s.column - pre_state.column};

        ostringstream msg;
        (msg << ... << forward<Args>(ostream_args)) << '\n'
            << string(28, ' ') << "(" << s.line << ", " << s.column << "): " << code;

        if (s.peek() != '\0')    s.advance();

        return make_token(TokenName::ERROR, msg.str());
    }

    inline Token make_token (TokenName name, TokenVal value = 0)
    {
        return {name, value, pre_state.line, pre_state.column};
    }

    Token simply (TokenName name)
    {
        s.advance();
        return make_token(name);
    }

    Token expect (char expected, TokenName name)
    {
        if (s.next() == expected)    return simply(name);
        else                         return error("Unrecognized character '", s.peek(), "'");
    }

    Token follow (char expected, TokenName ifyes, TokenName ifno)
    {
        if (s.next() == expected)    return simply(ifyes);
        else                         return make_token(ifno);
    }

    Token divide_or_comment ()
    {
        if (s.next() != '*')    return make_token(TokenName::OP_DIVIDE);

        while (s.next() != '\0')
        {
            if (s.peek() == '*' && s.next() == '/')
            {
                s.advance();
                return next_token();
            }
        }

        return error("End-of-file in comment. Closing comment characters not found.");
    }

    Token char_lit ()
    {
        int n = s.next();

        if (n == '\'')    return error("Empty character constant");

        if (n == '\\')    switch (s.next())
                          {
                              case 'n'  :    n = '\n'; break;
                              case '\\' :    n = '\\'; break;
                              default   :    return error("Unknown escape sequence \\", s.peek());
                          }

        if (s.next() != '\'')    return error("Multi-character constant");

        s.advance();
        return make_token(TokenName::INTEGER, n);
    }

    Token string_lit ()
    {
        string text = "";

        while (s.next() != '"')
            switch (s.peek())
            {
                case '\\' :    switch (s.next())
                               {
                                   case 'n'  :    text += '\n'; continue;
                                   case '\\' :    text += '\\'; continue;
                                   default   :    return error("Unknown escape sequence \\", s.peek());
                               }

                case '\n' :    return error("End-of-line while scanning string literal."
                                            " Closing string character not found before end-of-line.");

                case '\0' :    return error("End-of-file while scanning string literal."
                                            " Closing string character not found.");

                default   :    text += s.peek();
            }

        s.advance();
        return make_token(TokenName::STRING, text);
    }

    static inline bool is_id_start (char c)    { return isalpha(static_cast<unsigned char>(c)) || c == '_'; }
    static inline bool is_id_end   (char c)    { return isalnum(static_cast<unsigned char>(c)) || c == '_'; }
    static inline bool is_digit    (char c)    { return isdigit(static_cast<unsigned char>(c));             }

    Token identifier ()
    {
        string text (1, s.peek());

        while (is_id_end(s.next()))    text += s.peek();

        auto i = keywords.find(text);
        if (i != keywords.end())    return make_token(i->second);

        return make_token(TokenName::IDENTIFIER, text);
    }

    Token integer_lit ()
    {
        while (is_digit(s.next()));

        if (is_id_start(s.peek()))
            return error("Invalid number. Starts like a number, but ends in non-numeric characters.");

        int n;

        auto r = from_chars(pre_state.pos, s.pos, n);
        if (r.ec == errc::result_out_of_range)    return error("Number exceeds maximum value");

        return make_token(TokenName::INTEGER, n);
    }
}; // class Lexer

const map<string, TokenName> Lexer::keywords =
{
    {"else",  TokenName::KEYWORD_ELSE},
    {"if",    TokenName::KEYWORD_IF},
    {"print", TokenName::KEYWORD_PRINT},
    {"putc",  TokenName::KEYWORD_PUTC},
    {"while", TokenName::KEYWORD_WHILE}
};

int main (int argc, char* argv[])
{
    string in  = (argc > 1) ? argv[1] : "stdin";
    string out = (argc > 2) ? argv[2] : "stdout";

    with_IO(in, out, [](string input)
    {
        Lexer lexer {input.data()};

        string s = "Location  Token name        Value\n"
                   "--------------------------------------\n";

        while (lexer.has_more())    s += to_string(lexer.next_token());
        return s;
    });
}


        >>SOURCE FORMAT IS FREE
*> this code is dedicated to the public domain
*> (GnuCOBOL) 2.3-dev.0
identification division.
program-id. lexer.
environment division.
configuration section.
repository. function all intrinsic.
input-output section.
file-control.
    select input-file assign using input-name
        status input-status
        organization line sequential.
data division.

file section.
fd  input-file.
01  input-record pic x(98).

working-storage section.
01  input-name pic x(32).
01  input-status pic xx.
01  input-length pic 99.

01  output-name pic x(32) value spaces.
01  output-status pic xx.
01  output-record pic x(64).

01  line-no pic 999 value 0.
01  col-no pic 99.
01  col-no-max pic 99.
01  col-increment pic 9 value 1.
01  start-col pic 99.
01  outx pic 99.
01  out-lim pic 99 value 48.

01  output-line value spaces.
    03  out-line pic zzzz9.
    03  out-column pic zzzzzz9.
    03  message-area.
        05  filler pic xxx.
        05  token pic x(16).
        05  out-value pic x(48).
        05  out-integer redefines out-value pic zzzzz9.
        05  out-integer1 redefines out-value pic zzzzzz9. *> to match the python lexer

01  error-record.
    03  error-line pic zzzz9 value 0.
    03  error-col pic zzzzzz9 value 0.
    03  error-message pic x(68) value spaces.

01  scan-state pic x(16) value spaces.
01  current-character pic x.
01  previous-character pic x.

procedure division chaining input-name.
start-lexer.
    if input-name <> spaces
        open input input-file
        if input-status = '35'
            string 'in lexer ' trim(input-name) ' not found' into error-message
            perform report-error
        end-if
    end-if
    perform read-input-file
    perform until input-status <> '00'
        add 1 to line-no
        move line-no to out-line
        move length(trim(input-record,trailing)) to col-no-max
        move 1 to col-no
        move space to previous-character
        perform until col-no > col-no-max
            move col-no to out-column
            move input-record(col-no:1) to current-character
            evaluate scan-state

            when 'identifier'
                if current-character >= 'A' and <= 'Z'
                or (current-character >= 'a' and <= 'z')
                or (current-character >= '0' and <= '9')
                or current-character = '_'
                    perform increment-outx
                    move current-character to out-value(outx:1)
                    if col-no = col-no-max
                        perform process-identifier
                    end-if
                else
                    perform process-identifier
                    if current-character <> space
                        move 0 to col-increment
                    end-if
                end-if

            when 'integer'
                evaluate true
                when current-character >= '0' and <= '9'
                    perform increment-outx
                    move current-character to out-value(outx:1)
                    if col-no = col-no-max
                        move numval(out-value) to out-integer
                        move 'Integer' to token
                    end-if
                when current-character >= 'A' and <= 'Z'
                when current-character >= 'a' and <= 'z'
                    move 'in lexer invalid integer' to error-message
                    perform report-error
                when other
                    if outx > 5
                        move numval(out-value) to out-integer1 *> to match the python lexer
                    else
                        move numval(out-value) to out-integer
                    end-if
                    move 'Integer' to token
                    if current-character <> space
                        move 0 to col-increment
                    end-if
                end-evaluate

            when 'comment'
                if previous-character = '*' and current-character = '/'
                    move 'comment' to token
                end-if

            when 'quote'
                evaluate current-character also outx
                when '"' also 0
                    string 'in lexer empty string' into error-message
                    perform report-error
                when '"' also any
                    perform increment-outx
                    move current-character to out-value(outx:1)
                    move 'String' to token
                when other
                    if col-no = col-no-max
                        string 'in lexer missing close quote' into error-message
                        perform report-error
                    else
                        perform increment-outx
                        move current-character to out-value(outx:1)
                    end-if
                end-evaluate

            when 'character'
                evaluate current-character also outx
                when "'" also 0
                    string 'in lexer empty character constant' into error-message
                    perform report-error
                when "'" also 1
                    subtract 1 from ord(out-value(1:1)) giving out-integer
                    move 'Integer' to token
                when "'" also 2
                    evaluate true
                    when out-value(1:2) = '\n'
                        move 10 to out-integer
                    when out-value(1:2) = '\\'
                        subtract 1 from ord('\') giving out-integer      *> ' (workaround a Rosetta Code highlighter problem)
                    when other
                        string 'in lexer unknown escape sequence ' out-value(1:2)
                            into error-message
                        perform report-error
                    end-evaluate
                    move 'Integer' to token
                when "'" also any
                    string 'in lexer multicharacter constant' into error-message
                    perform report-error
                when other
                    if col-no = col-no-max
                        string 'in lexer missing close quote' into error-message
                        perform report-error
                    end-if
                    perform increment-outx
                    move current-character to out-value(outx:1)
                end-evaluate

            when 'and'
                evaluate previous-character also current-character
                when '&' also '&'
                    move 'Op_and' to token
                when other
                    string 'in lexer AND error' into error-message
                    perform report-error
                end-evaluate

            when 'or'
                evaluate previous-character also current-character
                when '|' also '|'
                    move 'Op_or' to token
                when other
                    string 'in lexer OR error' into error-message
                    perform report-error
                end-evaluate

            when 'ambiguous'
                evaluate previous-character also current-character
                when '/' also '*'
                    move 'comment' to scan-state
                    subtract 1 from col-no giving start-col
                when '/' also any
                    move 'Op_divide' to token
                    move 0 to col-increment

                when '=' also '='
                    move 'Op_equal' to token
                when '=' also any
                    move 'Op_assign' to token
                    move 0 to col-increment

                when '<' also '='
                    move 'Op_lessequal' to token
                when '<' also any
                    move 'Op_less' to token
                    move 0 to col-increment

                when '>' also '='
                    move 'Op_greaterequal' to token
                when '>'also any
                    move 'Op_greater' to token
                    move 0 to col-increment

                when '!' also '='
                    move 'Op_notequal' to token
                when '!' also any
                    move 'Op_not' to token
                    move 0 to col-increment

                when other
                    display input-record
                    string 'in lexer ' trim(scan-state)
                        ' unknown character "' current-character '"'
                        ' with previous character "' previous-character '"'
                        into error-message
                    perform report-error
                end-evaluate

            when other
                move col-no to start-col
                evaluate current-character
                when space
                    continue
                when >= 'A' and <= 'Z'
                when >= 'a' and <= 'z'
                    move 'identifier' to scan-state
                    move 1 to outx
                    move current-character to out-value
                when >= '0' and <= '9'
                    move 'integer' to scan-state
                    move 1 to outx
                    move current-character to out-value
                when '&'
                    move 'and' to scan-state
                when '|'
                    move 'or' to scan-state
                when '"'
                    move 'quote' to scan-state
                    move 1 to outx
                    move current-character to out-value
                when "'"
                    move 'character' to scan-state
                    move 0 to outx
                when '{'
                    move 'LeftBrace' to token
                when '}'
                    move 'RightBrace' to token
                when '('
                    move 'LeftParen' to token
                when ')'
                    move 'RightParen' to token
                when '+'
                    move 'Op_add' to token
                when '-'
                    move 'Op_subtract' to token
                when '*'
                    move 'Op_multiply' to token
                when '%'
                    move 'Op_mod' to token
                when ';'
                    move 'Semicolon' to token
                when ','
                    move 'Comma' to token
                when '/'
                when '<'
                when '>'
                when '='
                when '='
                when '<'
                when '>'
                when '!'
                    move 'ambiguous' to scan-state
                when other
                    string 'in lexer unknown character "' current-character '"'
                        into error-message
                    perform report-error
                end-evaluate
            end-evaluate

            if token <> spaces
                perform process-token
            end-if

            move current-character to previous-character
            add col-increment to col-no
            move 1 to col-increment
        end-perform
        if scan-state = 'ambiguous'
            evaluate previous-character
            when '/'
                move 'Op_divide' to token
                perform process-token

            when '='
                move 'Op_assign' to token
                perform process-token

            when '<'
                move 'Op_less' to token
                perform process-token

            when '>'
                move 'Op_greater' to token
                perform process-token

            when '!'
                move 'Op_not' to token
                perform process-token

            when other
                string 'in lexer unresolved ambiguous
                    "' previous-character '" at end of line'
                into error-message
                perform report-error
            end-evaluate
        end-if
        perform read-input-file
    end-perform

    evaluate true
    when input-status <> '10'
        string 'in lexer ' trim(input-name) ' invalid input status ' input-status
            into error-message
        perform report-error
    when scan-state = 'comment'
        string 'in lexer unclosed comment at end of input' into error-message
        perform report-error
     end-evaluate

    move 'End_of_input' to token
    move 1 to out-column
    move 1 to start-col
    add 1 to line-no
    perform process-token

    close input-file
    stop run
    .
process-identifier.
    evaluate true
    when out-value = 'print'
        move 'Keyword_print' to token
        move spaces to out-value
    when out-value = 'while'
        move 'Keyword_while' to token
        move spaces to out-value
    when out-value = 'if'
        move 'Keyword_if' to token
        move spaces to out-value
    when out-value = 'else'
        move 'Keyword_else' to token
        move spaces to out-value
    when out-value = 'putc'
        move 'Keyword_putc' to token
        move spaces to out-value
    when other
        move 'Identifier' to token
    end-evaluate
    .
increment-outx.
    if outx >= out-lim
        string 'in lexer token value length exceeds ' out-lim into error-message
        perform report-error
    end-if
    add 1 to outx
    .
process-token.
    if token <> 'comment'
        move start-col to out-column
        move line-no to out-line
        display output-line
    end-if
    move 0 to start-col
    move spaces to scan-state message-area
    .
report-error.
    move line-no to error-line
    move start-col to error-col
    display error-record
    close input-file
    stop run with error status -1
    .
read-input-file.
    if input-name = spaces
        move '00' to input-status
        accept input-record on exception move '10' to input-status end-accept
    else
        read input-file
    end-if
    .
end program lexer.


(defpackage #:lexical-analyzer
  (:use #:cl #:sb-gray)
  (:export #:main))

(in-package #:lexical-analyzer)

(defconstant +lex-symbols-package+ (or (find-package :lex-symbols)
                                       (make-package :lex-symbols)))

(defclass counting-character-input-stream (fundamental-character-input-stream)
  ((stream :type stream :initarg :stream :reader stream-of)
   (line :type fixnum :initform 1 :accessor line-of)
   (column :type fixnum :initform 0 :accessor column-of)
   (prev-column :type (or null fixnum) :initform nil :accessor prev-column-of))
  (:documentation "Character input stream that counts lines and columns."))

(defmethod stream-read-char ((stream counting-character-input-stream))
  (let ((ch (read-char (stream-of stream) nil :eof)))
    (case ch
      (#\Newline
       (incf (line-of stream))
       (setf (prev-column-of stream) (column-of stream)
             (column-of stream) 0))
      (t
       (incf (column-of stream))))
    ch))

(defmethod stream-unread-char ((stream counting-character-input-stream) char)
  (unread-char char (stream-of stream))
  (case char
      (#\Newline
       (decf (line-of stream))
       (setf (column-of stream) (prev-column-of stream)))
      (t
       (decf (column-of stream)))))

(defstruct token
  (name nil :type symbol)
  (value nil :type t)
  (line nil :type fixnum)
  (column nil :type fixnum))

(defun lexer-error (format-control &rest args)
  (apply #'error format-control args))

(defun handle-divide-or-comment (stream char)
  (declare (ignore char))
  (case (peek-char nil stream t nil t)
    (#\* (loop with may-end = nil
                 initially (read-char stream t nil t)
               for ch = (read-char stream t nil t)
               until (and may-end (char= ch #\/))
               do (setf may-end (char= ch #\*))
               finally (return (read stream t nil t))))
    (t (make-token :name :op-divide :line (line-of stream) :column (column-of stream)))))

(defun make-constant-handler (token-name)
  (lambda (stream char)
    (declare (ignore char))
    (make-token :name token-name :line (line-of stream) :column (column-of stream))))

(defun make-this-or-that-handler (expect then &optional else)
  (lambda (stream char)
    (declare (ignore char))
    (let ((line (line-of stream))
          (column (column-of stream))
          (next (peek-char nil stream nil nil t)))
      (cond ((and expect (char= next expect))
             (read-char stream nil nil t)
             (make-token :name then :line line :column column))
            (else
             (make-token :name else :line line :column column))
            (t
             (lexer-error "Unrecognized character '~A'" next))))))

(defun identifier? (symbol)
  (and (symbolp symbol)
       (not (keywordp symbol))
       (let ((name (symbol-name symbol)))
         (and (find (char name 0) "_abcdefghijklmnopqrstuvwxyz" :test #'char-equal)
              (or (< (length name) 2)
                  (not (find-if-not (lambda (ch)
                                      (find ch "_abcdefghijklmnopqrstuvwxyz0123456789"
                                            :test #'char-equal))
                                    name :start 1)))))))

(defun id->keyword (id line column)
  (case id
    (lex-symbols::|if|    (make-token :name :keyword-if :line line :column column))
    (lex-symbols::|else|  (make-token :name :keyword-else :line line :column column))
    (lex-symbols::|while| (make-token :name :keyword-while :line line :column column))
    (lex-symbols::|print| (make-token :name :keyword-print :line line :column column))
    (lex-symbols::|putc|  (make-token :name :keyword-putc :line line :column column))
    (t nil)))

(defun handle-identifier (stream char)
  (let ((*readtable* (copy-readtable)))
    (set-syntax-from-char char #\z)
    (let ((line (line-of stream))
          (column (column-of stream)))
      (unread-char char stream)
      (let ((obj (read stream t nil t)))
        (if (identifier? obj)
            (or (id->keyword obj line column)
                (make-token :name :identifier :value obj :line line :column column))
            (lexer-error "Invalid identifier name: ~A" obj))))))

(defun handle-integer (stream char)
  (let ((*readtable* (copy-readtable)))
    (set-syntax-from-char char #\z)
    (let ((line (line-of stream))
          (column (column-of stream)))
      (unread-char char stream)
      (let ((obj (read stream t nil t)))
        (if (integerp obj)
            (make-token :name :integer :value obj :line line :column column)
            (lexer-error "Invalid integer: ~A" obj))))))

(defun handle-char-literal (stream char)
  (declare (ignore char))
  (let* ((line (line-of stream))
         (column (column-of stream))
         (ch (read-char stream t nil t))
         (parsed (case ch
                   (#\' (lexer-error "Empty character constant"))
                   (#\Newline (lexer-error "New line in character literal"))
                   (#\\ (let ((next-ch (read-char stream t nil t)))
                          (case next-ch
                            (#\n #\Newline)
                            (#\\ #\\)
                            (t (lexer-error "Unknown escape sequence: \\~A" next-ch)))))
                   (t ch))))
    (if (char= #\' (read-char stream t nil t))
        (make-token :name :integer :value (char-code parsed) :line line :column column)
        (lexer-error "Only one character is allowed in character literal"))))

(defun handle-string (stream char)
  (declare (ignore char))
  (loop with result = (make-array 0 :element-type 'character :adjustable t :fill-pointer t)
        with line = (line-of stream)
        with column = (column-of stream)
        for ch = (read-char stream t nil t)
        until (char= ch #\")
        do (setf ch (case ch
                      (#\Newline (lexer-error "New line in string"))
                      (#\\ (let ((next-ch (read-char stream t nil t)))
                             (case next-ch
                               (#\n #\Newline)
                               (#\\ #\\)
                               (t (lexer-error "Unknown escape sequence: \\~A" next-ch)))))
                      (t ch)))
           (vector-push-extend ch result)
        finally (return (make-token :name :string :value result :line line :column column))))

(defun make-lexer-readtable ()
  (let ((*readtable* (copy-readtable nil)))
    (setf (readtable-case *readtable*) :preserve)
    (set-syntax-from-char #\\ #\z)
    (set-syntax-from-char #\# #\z)
    (set-syntax-from-char #\` #\z)

    ;; operators
    (set-macro-character #\* (make-constant-handler :op-multiply))
    (set-macro-character #\/ #'handle-divide-or-comment)
    (set-macro-character #\% (make-constant-handler :op-mod))
    (set-macro-character #\+ (make-constant-handler :op-add))
    (set-macro-character #\- (make-constant-handler :op-subtract))
    (set-macro-character #\< (make-this-or-that-handler #\= :op-lessequal :op-less))
    (set-macro-character #\> (make-this-or-that-handler #\= :op-greaterequal :op-greater))
    (set-macro-character #\= (make-this-or-that-handler #\= :op-equal :op-assign))
    (set-macro-character #\! (make-this-or-that-handler #\= :op-notequal :op-not))
    (set-macro-character #\& (make-this-or-that-handler #\& :op-and))
    (set-macro-character #\| (make-this-or-that-handler #\| :op-or))

    ;; symbols
    (set-macro-character #\( (make-constant-handler :leftparen))
    (set-macro-character #\) (make-constant-handler :rightparen))
    (set-macro-character #\{ (make-constant-handler :leftbrace))
    (set-macro-character #\} (make-constant-handler :rightbrace))
    (set-macro-character #\; (make-constant-handler :semicolon))
    (set-macro-character #\, (make-constant-handler :comma))

    ;; identifiers & keywords
    (set-macro-character #\_ #'handle-identifier t)
    (loop for ch across "abcdefghijklmnopqrstuvwxyz"
          do (set-macro-character ch #'handle-identifier t))
    (loop for ch across "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
          do (set-macro-character ch #'handle-identifier t))

    ;; integers
    (loop for ch across "0123456789"
          do (set-macro-character ch #'handle-integer t))
    (set-macro-character #\' #'handle-char-literal)

    ;; strings
    (set-macro-character #\" #'handle-string)

    *readtable*))

(defun lex (stream)
  (loop with *readtable* = (make-lexer-readtable)
        with *package* = +lex-symbols-package+
        with eof = (gensym)
        with counting-stream = (make-instance 'counting-character-input-stream :stream stream)
        for token = (read counting-stream nil eof)
        until (eq token eof)
        do (format t "~5D ~5D [email protected][ ~S~]~%"
                   (token-line token) (token-column token) (token-name token) (token-value token))
        finally (format t "~5D ~5D ~15A~%"
                        (line-of counting-stream) (column-of counting-stream) :end-of-input)
                (close counting-stream)))

(defun main ()
  (lex *standard-input*))


#!/bin/env elixir
# -*- elixir -*-

defmodule Lex do

  def main args do
    {inpf_name, outf_name, exit_status} =
      case args do
        [] -> {"-", "-", 0}
        [name] -> {name, "-", 0}
        [name1, name2] -> {name1, name2, 0}
        [name1, name2 | _] -> {name1, name2, usage_error()}
      end

    {inpf, outf, exit_status} =
      case {inpf_name, outf_name, exit_status} do
        {"-", "-", 0} -> {:stdio, :stdio, 0}
        {name1, "-", 0} ->
          {inpf, exit_status} = open_file(name1, [:read])
          {inpf, :stdio, exit_status}
        {"-", name2, 0} ->
          {outf, exit_status} = open_file(name2, [:write])
          {:stdio, outf, exit_status}
        {name1, name2, 0} ->
          {inpf, exit_status} = open_file(name1, [:read])
          if exit_status != 0 do
            {inpf, name2, exit_status}
          else
            {outf, exit_status} = open_file(name2, [:write])
            {inpf, outf, exit_status}
          end
        _ -> {inpf_name, outf_name, exit_status}
      end

    exit_status =
      case exit_status do
        0 -> main_program inpf, outf
        _ -> exit_status
    end

    # Choose one.
    System.halt exit_status     # Fast exit.
    #System.stop exit_status    # Laborious cleanup.
  end

  def main_program inpf, outf do
    inp = make_inp inpf
    scan_text outf, inp
    exit_status = 0
    exit_status
  end

  def open_file name, rw do
    case File.open name, rw do
      {:ok, f} -> {f, 0}
      _ ->
        IO.write :stderr, "Cannot open "
        IO.write :stderr, name
        case rw do
          [:read] -> IO.puts " for input"
          [:write] -> IO.puts " for output"
        end
        {name, 1}
    end
  end

  def scan_text outf, inp do
    {toktup, inp} = get_next_token inp
    print_token outf, toktup
    case toktup do
      {"End_of_input", _, _, _} -> :ok
      _ -> scan_text outf, inp
    end
  end

  def print_token outf, {tok, arg, line_no, column_no} do
    IO.write outf, (String.pad_leading "#{line_no}", 5)
    IO.write outf, " "
    IO.write outf, (String.pad_leading "#{column_no}", 5)
    IO.write outf, "  "
    IO.write outf, tok
    case tok do
      "Identifier" ->
        IO.write outf, "     "
        IO.write outf, arg
      "Integer" ->
        IO.write outf, "        "
        IO.write outf, arg
      "String" ->
        IO.write outf, "         "
        IO.write outf, arg
      _ -> :ok
    end
    IO.puts outf, ""
  end

###-------------------------------------------------------------------
###
### The token dispatcher.
###

  def get_next_token inp do
    inp = skip_spaces_and_comments inp
    {ch, inp} = get_ch inp
    {chr, line_no, column_no} = ch
    ln = line_no
    cn = column_no
    case chr do
      :eof -> {{"End_of_input", "", ln, cn}, inp}
      "," -> {{"Comma", ",", ln, cn}, inp}
      ";" -> {{"Semicolon", ";", ln, cn}, inp}
      "(" -> {{"LeftParen", "(", ln, cn}, inp}
      ")" -> {{"RightParen", ")", ln, cn}, inp}
      "{" -> {{"LeftBrace", "{", ln, cn}, inp}
      "}" -> {{"RightBrace", "}", ln, cn}, inp}
      "*" -> {{"Op_multiply", "*", ln, cn}, inp}
      "/" -> {{"Op_divide", "/", ln, cn}, inp}
      "%" -> {{"Op_mod", "%", ln, cn}, inp}
      "+" -> {{"Op_add", "+", ln, cn}, inp}
      "-" -> {{"Op_subtract", "-", ln, cn}, inp}
      "<" ->
        {ch1, inp} = get_ch inp
        {chr1, _, _} = ch1
        case chr1 do
          "=" -> {{"Op_lessequal", "<=", ln, cn}, inp}
          _ -> {{"Op_less", "<", ln, cn}, (push_back ch1, inp)}
        end
      ">" ->
        {ch1, inp} = get_ch inp
        {chr1, _, _} = ch1
        case chr1 do
          "=" -> {{"Op_greaterequal", ">=", ln, cn}, inp}
          _ -> {{"Op_greater", ">", ln, cn}, (push_back ch1, inp)}
        end
      "=" ->
        {ch1, inp} = get_ch inp
        {chr1, _, _} = ch1
        case chr1 do
          "=" -> {{"Op_equal", "==", ln, cn}, inp}
          _ -> {{"Op_assign", "=", ln, cn}, (push_back ch1, inp)}
        end
      "!" ->
        {ch1, inp} = get_ch inp
        {chr1, _, _} = ch1
        case chr1 do
          "=" -> {{"Op_notequal", "!=", ln, cn}, inp}
          _ -> {{"Op_not", "!", ln, cn}, (push_back ch1, inp)}
        end
      "&" ->
        {ch1, inp} = get_ch inp
        {chr1, _, _} = ch1
        case chr1 do
          "&" -> {{"Op_and", "&&", ln, cn}, inp}
          _ -> unexpected_character ln, cn, chr
        end
      "|" ->
        {ch1, inp} = get_ch inp
        {chr1, _, _} = ch1
        case chr1 do
          "|" -> {{"Op_or", "||", ln, cn}, inp}
          _ -> unexpected_character ln, cn, chr
        end
      "\"" ->
        inp = push_back ch, inp
        scan_string_literal inp
      "'" ->
        inp = push_back ch, inp
        scan_character_literal inp
      _ ->
        cond do
          String.match? chr, ~r/^[[:digit:]]$/u ->
            inp = push_back ch, inp
            scan_integer_literal inp
          String.match? chr, ~r/^[[:alpha:]_]$/u ->
            inp = push_back ch, inp
            scan_identifier_or_reserved_word inp
          true -> unexpected_character ln, cn, chr
        end
    end
  end

###-------------------------------------------------------------------
###
### Skipping past spaces and /* ... */ comments.
###
### Comments are treated exactly like a bit of whitespace. They never
### make it to the dispatcher.
###

  def skip_spaces_and_comments inp do
    {ch, inp} = get_ch inp
    {chr, line_no, column_no} = ch
    cond do
      chr == :eof -> push_back ch, inp
      String.match? chr, ~r/^[[:space:]]$/u ->
        skip_spaces_and_comments inp
      chr == "/" ->
        {ch1, inp} = get_ch inp
        case ch1 do
          {"*", _, _} ->
            inp = scan_comment inp, line_no, column_no
            skip_spaces_and_comments inp
          _ -> push_back ch, (push_back ch1, inp)
        end
      true -> push_back ch, inp
    end
  end

  def scan_comment inp, line_no, column_no do
    {ch, inp} = get_ch inp
    case ch do
      {:eof, _, _} -> unterminated_comment line_no, column_no
      {"*", _, _} ->
        {ch1, inp} = get_ch inp
        case ch1 do
          {:eof, _, _} -> unterminated_comment line_no, column_no
          {"/", _, _} -> inp
          _ -> scan_comment inp, line_no, column_no
        end
      _ -> scan_comment inp, line_no, column_no
    end
  end

###-------------------------------------------------------------------
###
### Scanning of integer literals, identifiers, and reserved words.
###
### These three types of token are very similar to each other.
###

  def scan_integer_literal inp do
    # Scan an entire word, not just digits. This way we detect
    # erroneous text such as "23skidoo".
    {line_no, column_no, inp} = get_position inp
    {word, inp} = scan_word inp
    if String.match? word, (~r/^[[:digit:]]+$/u) do
      {{"Integer", word, line_no, column_no}, inp}
    else
      invalid_integer_literal line_no, column_no, word
    end
  end

  def scan_identifier_or_reserved_word inp do
    # It is assumed that the first character is of the correct type,
    # thanks to the dispatcher.
    {line_no, column_no, inp} = get_position inp
    {word, inp} = scan_word inp
    tok =
      case word do
        "if" -> "Keyword_if"
        "else" -> "Keyword_else"
        "while" -> "Keyword_while"
        "print" -> "Keyword_print"
        "putc" -> "Keyword_putc"
        _ -> "Identifier"
      end
    {{tok, word, line_no, column_no}, inp}
  end

  def scan_word inp, word\\"" do
    {ch, inp} = get_ch inp
    {chr, _, _} = ch
    if String.match? chr, (~r/^[[:alnum:]_]$/u) do
      scan_word inp, (word <> chr)
    else
      {word, (push_back ch, inp)}
    end
  end

  def get_position inp do
    {ch, inp} = get_ch inp
    {_, line_no, column_no} = ch
    inp = push_back ch, inp
    {line_no, column_no, inp}
  end

###-------------------------------------------------------------------
###
### Scanning of string literals.
###
### It is assumed that the first character is the opening quote, and
### that the closing quote is the same character.
###

  def scan_string_literal inp do
    {ch, inp} = get_ch inp
    {quote_mark, line_no, column_no} = ch
    {contents, inp} = scan_str_lit inp, ch
    {{"String", quote_mark <> contents <> quote_mark,
      line_no, column_no},
     inp}
  end

  def scan_str_lit inp, ch, contents\\"" do
    {quote_mark, line_no, column_no} = ch
    {ch1, inp} = get_ch inp
    {chr1, line_no1, column_no1} = ch1
    if chr1 == quote_mark do
      {contents, inp}
    else
      case chr1 do
        :eof -> eoi_in_string_literal line_no, column_no
        "\n" -> eoln_in_string_literal line_no, column_no
        "\\" ->
          {ch2, inp} = get_ch inp
          {chr2, _, _} = ch2
          case chr2 do
            "n" -> scan_str_lit inp, ch, (contents <> "\\n")
            "\\" -> scan_str_lit inp, ch, (contents <> "\\\\")
            _ -> unsupported_escape line_no1, column_no1, chr2
          end
        _ -> scan_str_lit inp, ch, (contents <> chr1)
      end
    end
  end

###-------------------------------------------------------------------
###
### Scanning of character literals.
###
### It is assumed that the first character is the opening quote, and
### that the closing quote is the same character.
###
### The tedious part of scanning a character literal is distinguishing
### between the kinds of lexical error. (One might wish to modify the
### code to detect, as a distinct kind of error, end of line within a
### character literal.)
###

  def scan_character_literal inp do
    {ch, inp} = get_ch inp
    {_, line_no, column_no} = ch
    {ch1, inp} = get_ch inp
    {chr1, line_no1, column_no1} = ch1
    {intval, inp} =
      case chr1 do
        :eof -> unterminated_character_literal line_no, column_no
        "\\" ->
          {ch2, inp} = get_ch inp
          {chr2, _, _} = ch2
          case chr2 do
            :eof -> unterminated_character_literal line_no, column_no
            "n" -> {(:binary.first "\n"), inp}
            "\\" -> {(:binary.first "\\"), inp}
            _ -> unsupported_escape line_no1, column_no1, chr2
          end
        _ -> {(:binary.first chr1), inp}
      end
    inp = check_character_literal_end inp, ch
    {{"Integer", "#{intval}", line_no, column_no}, inp}
  end

  def check_character_literal_end inp, ch do
    {chr, _, _} = ch
    {{chr1, _, _}, inp} = get_ch inp
    if chr1 == chr do
      inp
    else
      # Lexical error.
      find_char_lit_end inp, ch
    end
  end

  def find_char_lit_end inp, ch do
    {chr, line_no, column_no} = ch
    {{chr1, _, _}, inp} = get_ch inp
    if chr1 == chr do
      multicharacter_literal line_no, column_no
    else
      case chr1 do
        :eof -> unterminated_character_literal line_no, column_no
        _ -> find_char_lit_end inp, ch
      end
    end
  end

###-------------------------------------------------------------------
###
### Character-at-a-time input, with unrestricted pushback, and with
### line and column numbering.
###

  def make_inp inpf do
    {inpf, [], 1, 1}
  end

  def get_ch {inpf, pushback, line_no, column_no} do
    case pushback do
      [head | tail] ->
        {head, {inpf, tail, line_no, column_no}}
      [] ->
        case IO.read(inpf, 1) do
          :eof ->
            {{:eof, line_no, column_no},
             {inpf, pushback, line_no, column_no}}
          {:error, _} ->
            {{:eof, line_no, column_no},
             {inpf, pushback, line_no, column_no}}
          chr ->
            case chr do
              "\n" ->
                {{chr, line_no, column_no},
                 {inpf, pushback, line_no + 1, 1}}
              _ ->
                {{chr, line_no, column_no},
                 {inpf, pushback, line_no, column_no + 1}}
            end
        end
    end
  end

  def push_back ch, {inpf, pushback, line_no, column_no} do
    {inpf, [ch | pushback], line_no, column_no}
  end

###-------------------------------------------------------------------
###
### Lexical and usage errors.
###

  def unterminated_comment line_no, column_no do
    raise "#{scriptname()}: unterminated comment at #{line_no}:#{column_no}"
  end

  def invalid_integer_literal line_no, column_no, word do
    raise "#{scriptname()}: invalid integer literal #{word} at #{line_no}:#{column_no}"
  end

  def unsupported_escape line_no, column_no, chr do
    raise "#{scriptname()}: unsupported escape \\#{chr} at #{line_no}:#{column_no}"
  end

  def eoi_in_string_literal line_no, column_no do
    raise "#{scriptname()}: end of input in string literal starting at #{line_no}:#{column_no}"
  end

  def eoln_in_string_literal line_no, column_no do
    raise "#{scriptname()}: end of line in string literal starting at #{line_no}:#{column_no}"
  end

  def multicharacter_literal line_no, column_no do
    raise "#{scriptname()}: unsupported multicharacter literal at #{line_no}:#{column_no}"
  end

  def unterminated_character_literal line_no, column_no do
    raise "#{scriptname()}: unterminated character literal starting at #{line_no}:#{column_no}"
  end

  def unexpected_character line_no, column_no, chr do
    raise "#{scriptname()}: unexpected character '#{chr}' at #{line_no}:#{column_no}"
  end

  def usage_error() do
    IO.puts "Usage: #{scriptname()} [INPUTFILE [OUTPUTFILE]]"
    IO.puts "If either of INPUTFILE or OUTPUTFILE is not present or is \"-\","
    IO.puts "standard input or standard output is used, respectively."
    exit_status = 2
    exit_status
  end

  def scriptname() do
    Path.basename(__ENV__.file)
  end

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

end ## module Lex

Lex.main(System.argv)


#!/usr/bin/emacs --script
;;
;; The Rosetta Code lexical analyzer in GNU Emacs Lisp.
;;
;; Migrated from the ATS. However, Emacs Lisp is not friendly to the
;; functional style of the ATS implementation; therefore the
;; differences are vast.
;;
;; (A Scheme migration could easily, on the other hand, have been
;; almost exact. It is interesting to contrast Lisp dialects and see
;; how huge the differences are.)
;;
;; The script currently takes input only from standard input and
;; writes the token stream only to standard output.
;;

(require 'cl-lib)

;;; The type of a character, consisting of its code point and where it
;;; occurred in the text.
(cl-defstruct (ch_t (:constructor make-ch (ichar line-no column-no)))
  ichar line-no column-no)

(defun ch-ichar (ch)
  (ch_t-ichar ch))

(defun ch-line-no (ch)
  (ch_t-line-no ch))

(defun ch-column-no (ch)
  (ch_t-column-no ch))

;;; The type of an "inputter", consisting of an open file for the
;;; text, a pushback buffer (which is an indefinitely deep stack of
;;; ch_t), an input buffer for the current line, and a position in the
;;; text.
(cl-defstruct inp_t file pushback line line-no column-no)

(defun make-inp (file)
  "Initialize a new inp_t."
  (make-inp_t :file file
              :pushback '()
              :line ""
              :line-no 0
              :column-no 0))

(defvar inp (make-inp t)
  "A global inp_t.")

(defun get-ch ()
  "Get a ch_t, either from the pushback buffer or from the input."
  (pcase (inp_t-pushback inp)
    (`(,ch . ,tail)
     ;; Emacs Lisp has only single value return, so the results come
     ;; back as a list rather than multiple values.
     (setq inp (make-inp_t :file (inp_t-file inp)
                           :pushback tail
                           :line (inp_t-line inp)
                           :line-no (inp_t-line-no inp)
                           :column-no (inp_t-column-no inp)))
     ch)
    ('()
     (let ((line (inp_t-line inp))
           (line-no (inp_t-line-no inp))
           (column-no (inp_t-column-no inp)))
       (when (string= line "")
         ;; Refill the buffer.
         (let ((text
                (condition-case nil (read-string "")
                  nil (error 'eoi))))
           (if (eq text 'eoi)
               (setq line 'eoi)
             (setq line (format "%s%c" text ?\n)))
           (setq line-no (1+ line-no))
           (setq column-no 1)))
       (if (eq line 'eoi)
           (progn
             (setq inp (make-inp_t :file (inp_t-file inp)
                                   :pushback (inp_t-pushback inp)
                                   :line line
                                   :line-no line-no
                                   :column-no column-no))
             (make-ch 'eoi line-no column-no))
         (let ((c (elt line 0))
               (line (substring line 1)))
           (setq inp (make-inp_t :file (inp_t-file inp)
                                 :pushback (inp_t-pushback inp)
                                 :line line
                                 :line-no line-no
                                 :column-no (1+ column-no)))
           (make-ch c line-no column-no)))))))

(defun get-new-line (file)
  ;; Currently "file" is ignored and the input must be from stdin.
  (read-from-minibuffer "" :default 'eoi))

(defun push-back (ch)
  "Push back a ch_t."
  (setq inp (make-inp_t :file (inp_t-file inp)
                        :pushback (cons ch (inp_t-pushback inp))
                        :line (inp_t-line inp)
                        :line-no (inp_t-line-no inp)
                        :column-no (inp_t-column-no inp))))

(defun get-position ()
  "Return the line-no and column-no of the next ch_t to be
returned by get-ch, assuming there are no more pushbacks
beforehand."
  (let* ((ch (get-ch))
         (line-no (ch-line-no ch))
         (column-no (ch-column-no ch)))
    (push-back ch)
    (list line-no column-no)))

(defun scan-text (outf)
  "The main loop."
  (cl-loop for toktup = (get-next-token)
           do (print-token outf toktup)
           until (string= (elt toktup 0) "End_of_input")))

(defun print-token (outf toktup)
  "Print a token, along with its position and possibly an
argument."
  ;; Currently outf is ignored, and the output goes to stdout.
  (pcase toktup
    (`(,tok ,arg ,line-no ,column-no)
     (princ (format "%5d %5d  %s" line-no column-no tok))
     (pcase tok
       ("Identifier" (princ (format "     %s\n" arg)))
       ("Integer" (princ (format "        %s\n" arg)))
       ("String" (princ (format "         %s\n" arg)))
       (_ (princ "\n"))))))

(defun get-next-token ()
   "The token dispatcher. Returns the next token, as a list along
with its argument and text position."
   (skip-spaces-and-comments)
   (let* ((ch (get-ch))
          (ln (ch-line-no ch))
          (cn (ch-column-no ch)))
     (pcase (ch-ichar ch)
       ('eoi (list "End_of_input" "" ln cn))
       (?, (list "Comma" "," ln cn))
       (?\N{SEMICOLON} (list "Semicolon" ";" ln cn))
       (?\N{LEFT PARENTHESIS} (list "LeftParen" "(" ln cn))
       (?\N{RIGHT PARENTHESIS} (list "RightParen" ")" ln cn))
       (?{ (list "LeftBrace" "{" ln cn))
       (?} (list "RightBrace" "}" ln cn))
       (?* (list "Op_multiply" "*" ln cn))
       (?/ (list "Op_divide" "/" ln cn))
       (?% (list "Op_mod" "%" ln cn))
       (?+ (list "Op_add" "+" ln cn))
       (?- (list "Op_subtract" "-" ln cn))
       (?< (let ((ch1 (get-ch)))
             (pcase (ch-ichar ch1)
               (?= (list "Op_lessequal" "<=" ln cn))
               (_ (push-back ch1)
                  (list "Op_less" "<" ln cn)))))
       (?> (let ((ch1 (get-ch)))
             (pcase (ch-ichar ch1)
               (?= (list "Op_greaterequal" ">=" ln cn))
               (_ (push-back ch1)
                  (list "Op_greater" ">" ln cn)))))
       (?= (let ((ch1 (get-ch)))
             (pcase (ch-ichar ch1)
               (?= (list "Op_equal" "==" ln cn))
               (_ (push-back ch1)
                  (list "Op_assign" "=" ln cn)))))
       (?! (let ((ch1 (get-ch)))
             (pcase (ch-ichar ch1)
               (?= (list "Op_notequal" "!=" ln cn))
               (_ (push-back ch1)
                  (list "Op_not" "!" ln cn)))))
       (?& (let ((ch1 (get-ch)))
             (pcase (ch-ichar ch1)
               (?& (list "Op_and" "&&" ln cn))
               (_ (unexpected-character ln cn (get-ichar ch))))))
       (?| (let ((ch1 (get-ch)))
             (pcase (ch-ichar ch1)
               (?| (list "Op_or" "||" ln cn))
               (_ (unexpected-character ln cn (get-ichar ch))))))
       (?\N{QUOTATION MARK} (push-back ch) (scan-string-literal))
       (?\N{APOSTROPHE} (push-back ch) (scan-character-literal))
       ((pred digitp) (push-back ch) (scan-integer-literal))
       ((pred identifier-start-p)
        (progn
          (push-back ch)
          (scan-identifier-or-reserved-word)))
       (c (unexpected-character ln cn c)))))

(defun skip-spaces-and-comments ()
  "Skip spaces and comments. A comment is treated as equivalent
to a run of spaces."
  (cl-loop for ch = (let ((ch1 (get-ch)))
                      (pcase (ch-ichar ch1)
                        (?/ (let* ((ch2 (get-ch))
                                   (line-no (ch-line-no ch1))
                                   (column-no (ch-column-no ch1))
                                   (position `(,line-no ,column-no)))
                              (pcase (ch-ichar ch2)
                                (?* (scan-comment position)
                                    (get-ch))
                                (_ (push-back ch2)
                                   ch1))))
                        (_ ch1)))
           while (spacep (ch-ichar ch))
           finally do (push-back ch)))

(defun scan-comment (position)
  (cl-loop for ch = (get-ch)
           for done = (comment-done-p ch position)
           until done))

(defun comment-done-p (ch position)
  (pcase (ch-ichar ch)
    ('eoi (apply 'unterminated-comment position))
    (?* (let ((ch1 (get-ch)))
          (pcase (ch-ichar ch1)
            ('eoi (apply 'unterminated-comment position))
            (?/ t)
            (_ nil))))
    (_ nil)))

(defun scan-integer-literal ()
  "Scan an integer literal, on the assumption that a digit has
been seen and pushed back."
  (let* ((position (get-position))
         (lst (scan-word))
         (s (list-to-string lst)))
    (if (all-digits-p lst)
        `("Integer" ,s . ,position)
      (apply 'illegal-integer-literal `(,@position , s)))))

(defun scan-identifier-or-reserved-word ()
   "Scan an identifier or reserved word, on the assumption that a
legal first character (for an identifier) has been seen and
pushed back."
   (let* ((position (get-position))
          (lst (scan-word))
          (s (list-to-string lst))
          (tok (pcase s
                 ("else" "Keyword_else")
                 ("if" "Keyword_if")
                 ("while" "Keyword_while")
                 ("print" "Keyword_print")
                 ("putc" "Keyword_putc")
                 (_ "Identifier"))))
     `(,tok ,s . ,position)))

(defun scan-word ()
  (cl-loop for ch = (get-ch)
           while (identifier-continuation-p (ch-ichar ch))
           collect (ch-ichar ch)
           finally do (push-back ch)))

(defun scan-string-literal ()
    "Scan a string literal, on the assumption that a double quote
has been seen and pushed back."
  (let* ((ch (get-ch))
         (_ (cl-assert (= (ch-ichar ch) ?\N{QUOTATION MARK})))
         (line-no (ch-line-no ch))
         (column-no (ch-column-no ch))
         (position `(,line-no ,column-no))
         (lst (scan-str-lit position))
         (lst `(?\N{QUOTATION MARK} ,@lst ?\N{QUOTATION MARK})))
    `("String" ,(list-to-string lst) . ,position)))

(defun scan-str-lit (position)
  (flatten
   (cl-loop for ch = (get-ch)
            until (= (ch-ichar ch) ?\N{QUOTATION MARK})
            collect (process-str-lit-character
                     (ch-ichar ch) position))))

(defun process-str-lit-character (c position)
  ;; NOTE: This script might insert a newline before any eoi, so that
  ;; "end-of-input-in-string-literal" never actually occurs. It is a
  ;; peculiarity of the script's input mechanism.
  (pcase c
    ('eoi (apply 'end-of-input-in-string-literal position))
    (?\n (apply 'end-of-line-in-string-literal position))
    (?\\ (let ((ch1 (get-ch)))
           (pcase (ch-ichar ch1)
             (?n '(?\\ ?n))
             (?\\ '(?\\ ?\\))
             (c (unsupported-escape (ch-line-no ch1)
                                    (ch-column-no ch1)
                                    c)))))
    (c c)))

(defun scan-character-literal ()
  "Scan a character literal, on the assumption that an ASCII
single quote (that is, a Unicode APOSTROPHE) has been seen and
pushed back."
  (let* ((toktup (scan-character-literal-without-checking-end))
         (line-no (elt toktup 2))
         (column-no (elt toktup 3))
         (position (list line-no column-no)))
    (check-char-lit-end position)
    toktup))

(defun check-char-lit-end (position)
  (let ((ch (get-ch)))
    (unless (and (integerp (ch-ichar ch))
                 (= (ch-ichar ch) ?\N{APOSTROPHE}))
      (push-back ch)
      (loop-to-char-lit-end position))))

(defun loop-to-char-lit-end (position)
  (cl-loop for ch = (get-ch)
           until (or (eq (ch-ichar ch) 'eoi)
                     (= (ch-ichar ch) ?\N{APOSTROPHE}))
           finally do (if (eq (ch-ichar ch) 'eoi)
                          (apply 'unterminated-character-literal
                                 position)
                        (apply 'multicharacter-literal position))))

(defun scan-character-literal-without-checking-end ()
  (let* ((ch (get-ch))
         (_ (cl-assert (= (ch-ichar ch) ?\N{APOSTROPHE})))
         (line-no (ch-line-no ch))
         (column-no (ch-column-no ch))
         (position (list line-no column-no))
         (ch1 (get-ch)))
    (pcase (ch-ichar ch1)
      ('eoi (apply 'unterminated-character-literal position))
      (?\\ (let ((ch2 (get-ch)))
             (pcase (ch-ichar ch2)
               ('eoi (apply 'unterminated-character-literal position))
               (?n `("Integer" ,(format "%d" ?\n) . ,position))
               (?\\ `("Integer" ,(format "%d" ?\\) . ,position))
               (c (unsupported-escape (ch-line-no ch1)
                                      (ch-column-no ch1)
                                      c)))))
      (c `("Integer" ,(format "%d" c) . ,position)))))

(defun spacep (c)
  (and (integerp c) (or (= c ?\N{SPACE})
                        (and (<= 9 c) (<= c 13)))))

(defun digitp (c)
  (and (integerp c) (<= ?0 c) (<= c ?9)))

(defun lowerp (c)
  ;; Warning: in EBCDIC, this kind of test for "alphabetic" is no
  ;; good. The letters are not contiguous.
  (and (integerp c) (<= ?a c) (<= c ?z)))

(defun upperp (c)
  ;; Warning: in EBCDIC, this kind of test for "alphabetic" is no
  ;; good. The letters are not contiguous.
  (and (integerp c) (<= ?A c) (<= c ?Z)))

(defun alphap (c)
  (or (lowerp c) (upperp c)))

(defun identifier-start-p (c)
  (and (integerp c) (or (alphap c) (= c ?_))))

(defun identifier-continuation-p (c)
  (and (integerp c) (or (alphap c) (= c ?_) (digitp c))))

(defun all-digits-p (thing)
  (cl-loop for c in thing
           if (not (digitp c)) return nil
           finally return t))

(defun list-to-string (lst)
  "Convert a list of characters to a string."
  (apply 'string lst))

(defun flatten (lst)
  "Flatten nested lists. (The implementation is recursive and not
for very long lists.)"
  (pcase lst
    ('() '())
    (`(,head . ,tail)
     (if (listp head)
         (append (flatten head) (flatten tail))
       (cons head (flatten tail))))))

(defun unexpected-character (line-no column-no c)
  (error (format "unexpected character '%c' at %d:%d"
                 c line-no column-no)))

(defun unsupported-escape (line-no column-no c)
  (error (format "unsupported escape \\%c at %d:%d"
                 c line-no column-no)))

(defun illegal-integer-literal (line-no column-no s)
  (error (format "illegal integer literal \"%s\" at %d:%d"
                 s line-no column-no)))

(defun unterminated-character-literal (line-no column-no)
  (error (format "unterminated character literal starting at %d:%d"
                 line-no column-no)))

(defun multicharacter-literal (line-no column-no)
  (error (format
          "unsupported multicharacter literal starting at %d:%d"
          line-no column-no)))

(defun end-of-input-in-string-literal (line-no column-no)
  (error (format "end of input in string literal starting at %d:%d"
                 line-no column-no)))

(defun end-of-line-in-string-literal (line-no column-no)
  (error (format "end of line in string literal starting at %d:%d"
                 line-no column-no)))

(defun unterminated-comment (line-no column-no)
  (error (format "unterminated comment starting at %d:%d"
                 line-no column-no)))

(defun main ()
  (setq inp (make-inp t))
  (scan-text t))

(main)


#!/bin/env escript
%%%-------------------------------------------------------------------

-record (inp_t, {inpf, pushback, line_no, column_no}).

main (Args) ->
   main_program (Args).

main_program ([]) ->
   scan_from_inpf_to_outf ("-", "-"),
   halt (0);
main_program ([Inpf_filename]) ->
   scan_from_inpf_to_outf (Inpf_filename, "-"),
   halt (0);
main_program ([Inpf_filename, Outf_filename]) ->
   scan_from_inpf_to_outf (Inpf_filename, Outf_filename),
   halt (0);
main_program ([_, _ | _]) ->
   ProgName = escript:script_name (),
   io:put_chars (standard_error, "Usage: "),
   io:put_chars (standard_error, ProgName),
   io:put_chars (standard_error, " [INPUTFILE [OUTPUTFILE]]\n"),
   halt (1).

scan_from_inpf_to_outf ("-", "-") ->
   scan_input (standard_io, standard_io);
scan_from_inpf_to_outf (Inpf_filename, "-") ->
   case file:open (Inpf_filename, [read]) of
      {ok, Inpf} -> scan_input (Inpf, standard_io);
      _ -> open_failure (Inpf_filename, "input")
   end;
scan_from_inpf_to_outf ("-", Outf_filename) ->
   case file:open (Outf_filename, [write]) of
      {ok, Outf} -> scan_input (standard_io, Outf);
      _ -> open_failure (Outf_filename, "output")
   end;
scan_from_inpf_to_outf (Inpf_filename, Outf_filename) ->
   case file:open(Inpf_filename, [read]) of
      {ok, Inpf} ->
         case file:open (Outf_filename, [write]) of
            {ok, Outf} -> scan_input (Inpf, Outf);
            _ -> open_failure (Outf_filename, "output")
         end;
      _ -> open_failure (Inpf_filename, "input")
   end.

open_failure (Filename, ForWhat) ->
   ProgName = escript:script_name (),
   io:put_chars (standard_error, ProgName),
   io:put_chars (standard_error, ": failed to open \""),
   io:put_chars (standard_error, Filename),
   io:put_chars (standard_error, "\" for "),
   io:put_chars (standard_error, ForWhat),
   io:put_chars (standard_error, "\n"),
   halt (1).

scan_input (Inpf, Outf) ->
   scan_text (Outf, make_inp (Inpf)).

scan_text (Outf, Inp) ->
   {TokTup, Inp1} = get_next_token (Inp),
   print_token (Outf, TokTup),
   case TokTup of
      {"End_of_input", _, _, _} -> ok;
      _ -> scan_text (Outf, Inp1)
   end.

print_token (Outf, {Tok, Arg, Line_no, Column_no}) ->
   S_line_no = erlang:integer_to_list (Line_no),
   S_column_no = erlang:integer_to_list (Column_no),
   io:put_chars (Outf, string:pad (S_line_no, 5, leading)),
   io:put_chars (Outf, " "),
   io:put_chars (Outf, string:pad (S_column_no, 5, leading)),
   io:put_chars (Outf, "  "),
   io:put_chars (Outf, Tok),
   {Padding, Arg1} =
      case Tok of
         "Identifier" -> {"     ", Arg};
         "Integer" -> {"        ", Arg};
         "String" -> {"         ", Arg};
         _ -> {"", ""}
      end,
   io:put_chars (Outf, Padding),
   io:put_chars (Outf, Arg1),
   io:put_chars ("\n").

%%%-------------------------------------------------------------------
%%%
%%% The token dispatcher.
%%%

get_next_token (Inp) ->
   Inp00 = skip_spaces_and_comments (Inp),
   {Ch, Inp0} = get_ch (Inp00),
   {Char, Line_no, Column_no} = Ch,
   Ln = Line_no,
   Cn = Column_no,
   case Char of
      eof -> {{"End_of_input", "", Ln, Cn}, Inp0};
      "," -> {{"Comma", ",", Ln, Cn}, Inp0};
      ";" -> {{"Semicolon", ";", Ln, Cn}, Inp0};
      "(" -> {{"LeftParen", "(", Ln, Cn}, Inp0};
      ")" -> {{"RightParen", ")", Ln, Cn}, Inp0};
      "{" -> {{"LeftBrace", "{", Ln, Cn}, Inp0};
      "}" -> {{"RightBrace", "}", Ln, Cn}, Inp0};
      "*" -> {{"Op_multiply", "*", Ln, Cn}, Inp0};
      "/" -> {{"Op_divide", "/", Ln, Cn}, Inp0};
      "%" -> {{"Op_mod", "%", Ln, Cn}, Inp0};
      "+" -> {{"Op_add", "+", Ln, Cn}, Inp0};
      "-" -> {{"Op_subtract", "-", Ln, Cn}, Inp0};
      "<" ->
         {Ch1, Inp1} = get_ch (Inp0),
         {Char1, _, _} = Ch1,
         case Char1 of
            "=" -> {{"Op_lessequal", "<=", Ln, Cn}, Inp1};
            _ -> {{"Op_less", "<", Ln, Cn}, push_back (Ch1, Inp1)}
         end;
      ">" ->
         {Ch1, Inp1} = get_ch (Inp0),
         {Char1, _, _} = Ch1,
         case Char1 of
            "=" -> {{"Op_greaterequal", ">=", Ln, Cn}, Inp1};
            _ -> {{"Op_greater", ">", Ln, Cn}, push_back (Ch1, Inp1)}
         end;
      "=" ->
         {Ch1, Inp1} = get_ch (Inp0),
         {Char1, _, _} = Ch1,
         case Char1 of
            "=" -> {{"Op_equal", "==", Ln, Cn}, Inp1};
            _ -> {{"Op_assign", "=", Ln, Cn}, push_back (Ch1, Inp1)}
         end;
      "!" ->
         {Ch1, Inp1} = get_ch (Inp0),
         {Char1, _, _} = Ch1,
         case Char1 of
            "=" -> {{"Op_notequal", "!=", Ln, Cn}, Inp1};
            _ -> {{"Op_not", "!", Ln, Cn}, push_back (Ch1, Inp1)}
         end;
      "&" ->
         {Ch1, Inp1} = get_ch (Inp0),
         {Char1, _, _} = Ch1,
         case Char1 of
            "&" -> {{"Op_and", "&&", Ln, Cn}, Inp1};
            _ -> unexpected_character (Ln, Cn, Char)
         end;
      "|" ->
         {Ch1, Inp1} = get_ch (Inp0),
         {Char1, _, _} = Ch1,
         case Char1 of
            "|" -> {{"Op_or", "||", Ln, Cn}, Inp1};
            _ -> unexpected_character (Ln, Cn, Char)
         end;
      "\"" ->
         Inp1 = push_back (Ch, Inp0),
         scan_string_literal (Inp1);
      "'" ->
         Inp1 = push_back (Ch, Inp0),
         scan_character_literal (Inp1);
      _ ->
         case is_digit (Char) of
            true ->
               Inp1 = push_back (Ch, Inp0),
               scan_integer_literal (Inp1);
            false ->
               case is_alpha_or_underscore (Char) of
                  true ->
                     Inp1 = push_back (Ch, Inp0),
                     scan_identifier_or_reserved_word (Inp1);
                  false ->
                     unexpected_character (Ln, Cn, Char)
               end
         end
   end.

%%%-------------------------------------------------------------------
%%%
%%% Skipping past spaces and /* ... */ comments.
%%%
%%% Comments are treated exactly like a bit of whitespace. They never
%%% make it to the dispatcher.
%%%

skip_spaces_and_comments (Inp) ->
   {Ch, Inp0} = get_ch (Inp),
   {Char, Line_no, Column_no} = Ch,
   case classify_char (Char) of
      eof -> push_back (Ch, Inp0);
      space -> skip_spaces_and_comments (Inp0);
      slash ->
         {Ch1, Inp1} = get_ch (Inp0),
         case Ch1 of
            {"*", _, _} ->
               Inp2 = scan_comment (Inp1, Line_no, Column_no),
               skip_spaces_and_comments (Inp2);
            _ -> push_back (Ch, (push_back (Ch1, Inp1)))
         end;
      other -> push_back (Ch, Inp0)
   end.

classify_char (Char) ->
   case Char of
      eof -> eof;
      "/" -> slash;
      _ -> case is_space (Char) of
              true -> space;
              false -> other
           end
   end.

scan_comment (Inp, Line_no, Column_no) ->
   {Ch0, Inp0} = get_ch (Inp),
   case Ch0 of
      {eof, _, _} -> unterminated_comment (Line_no, Column_no);
      {"*", _, _} ->
         {Ch1, Inp1} = get_ch (Inp0),
         case Ch1 of
            {eof, _, _} ->
               unterminated_comment (Line_no, Column_no);
            {"/", _, _} -> Inp1;
            _ -> scan_comment (Inp1, Line_no, Column_no)
         end;
      _ -> scan_comment (Inp0, Line_no, Column_no)
   end.

is_space (S) ->
   case re:run (S, "^[[:space:]]+$") of
      {match, _} -> true;
      _ -> false
   end.

%%%-------------------------------------------------------------------
%%%
%%% Scanning of integer literals, identifiers, and reserved words.
%%%
%%% These three types of token are very similar to each other.
%%%

scan_integer_literal (Inp) ->
   %% Scan an entire word, not just digits. This way we detect
   %% erroneous text such as "23skidoo".
   {Line_no, Column_no, Inp1} = get_position (Inp),
   {Word, Inp2} = scan_word (Inp1),
   case is_digit (Word) of
      true -> {{"Integer", Word, Line_no, Column_no}, Inp2};
      false -> invalid_integer_literal (Line_no, Column_no, Word)
   end.

scan_identifier_or_reserved_word (Inp) ->
   %% It is assumed that the first character is of the correct type,
   %% thanks to the dispatcher.
   {Line_no, Column_no, Inp1} = get_position (Inp),
   {Word, Inp2} = scan_word (Inp1),
   Tok =
      case Word of
         "if" -> "Keyword_if";
         "else" -> "Keyword_else";
         "while" -> "Keyword_while";
         "print" -> "Keyword_print";
         "putc" -> "Keyword_putc";
         _ -> "Identifier"
      end,
   {{Tok, Word, Line_no, Column_no}, Inp2}.

scan_word (Inp) ->
   scan_word_loop (Inp, "").

scan_word_loop (Inp, Word0) ->
   {Ch1, Inp1} = get_ch (Inp),
   {Char1, _, _} = Ch1,
   case is_alnum_or_underscore (Char1) of
      true -> scan_word_loop (Inp1, Word0 ++ Char1);
      false -> {Word0, push_back (Ch1, Inp1)}
   end.

get_position (Inp) ->
   {Ch1, Inp1} = get_ch (Inp),
   {_, Line_no, Column_no} = Ch1,
   Inp2 = push_back (Ch1, Inp1),
   {Line_no, Column_no, Inp2}.

is_digit (S) ->
   case re:run (S, "^[[:digit:]]+$") of
      {match, _} -> true;
      _ -> false
   end.

is_alpha_or_underscore (S) ->
   case re:run (S, "^[[:alpha:]_]+$") of
      {match, _} -> true;
      _ -> false
   end.

is_alnum_or_underscore (S) ->
   case re:run (S, "^[[:alnum:]_]+$") of
      {match, _} -> true;
      _ -> false
   end.

%%%-------------------------------------------------------------------
%%%
%%% Scanning of string literals.
%%%
%%% It is assumed that the first character is the opening quote, and
%%% that the closing quote is the same character.
%%%

scan_string_literal (Inp) ->
   {Ch1, Inp1} = get_ch (Inp),
   {Quote_mark, Line_no, Column_no} = Ch1,
   {Contents, Inp2} = scan_str_lit (Inp1, Ch1),
   Toktup = {"String", Quote_mark ++ Contents ++ Quote_mark,
             Line_no, Column_no},
   {Toktup, Inp2}.

scan_str_lit (Inp, Ch) -> scan_str_lit_loop (Inp, Ch, "").

scan_str_lit_loop (Inp, Ch, Contents) ->
   {Quote_mark, Line_no, Column_no} = Ch,
   {Ch1, Inp1} = get_ch (Inp),
   {Char1, Line_no1, Column_no1} = Ch1,
   case Char1 of
      Quote_mark -> {Contents, Inp1};
      eof -> eoi_in_string_literal (Line_no, Column_no);
      "\n" -> eoln_in_string_literal (Line_no, Column_no);
      "\\" ->
         {Ch2, Inp2} = get_ch (Inp1),
         {Char2, _, _} = Ch2,
         case Char2 of
            "n" ->
               scan_str_lit_loop (Inp2, Ch, Contents ++ "\\n");
            "\\" ->
               scan_str_lit_loop (Inp2, Ch, Contents ++ "\\\\");
            _ ->
               unsupported_escape (Line_no1, Column_no1, Char2)
         end;
      _ -> scan_str_lit_loop (Inp1, Ch, Contents ++ Char1)
   end.

%%%-------------------------------------------------------------------
%%%
%%% Scanning of character literals.
%%%
%%% It is assumed that the first character is the opening quote, and
%%% that the closing quote is the same character.
%%%
%%% The tedious part of scanning a character literal is distinguishing
%%% between the kinds of lexical error. (One might wish to modify the
%%% code to detect, as a distinct kind of error, end of line within a
%%% character literal.)
%%%

scan_character_literal (Inp) ->
   {Ch, Inp0} = get_ch (Inp),
   {_, Line_no, Column_no} = Ch,
   {Ch1, Inp1} = get_ch (Inp0),
   {Char1, Line_no1, Column_no1} = Ch1,
   {Intval, Inp3} =
      case Char1 of
         eof -> unterminated_character_literal (Line_no, Column_no);
         "\\" ->
            {Ch2, Inp2} = get_ch (Inp1),
            {Char2, _, _} = Ch2,
            case Char2 of
               eof -> unterminated_character_literal (Line_no,
                                                      Column_no);
               "n" -> {char_to_code ("\n"), Inp2};
               "\\" -> {char_to_code ("\\"), Inp2};
               _ -> unsupported_escape (Line_no1, Column_no1,
                                        Char2)
            end;
         _ -> {char_to_code (Char1), Inp1}
      end,
   Inp4 = check_character_literal_end (Inp3, Ch),
   {{"Integer", Intval, Line_no, Column_no}, Inp4}.

char_to_code (Char) ->
   %% Hat tip to https://archive.ph/BxZRS
   lists:flatmap (fun erlang:integer_to_list/1, Char).

check_character_literal_end (Inp, Ch) ->
   {Char, _, _} = Ch,
   {{Char1, _, _}, Inp1} = get_ch (Inp),
   case Char1 of
      Char -> Inp1;
      _ -> find_char_lit_end (Inp1, Ch)    % Handle a lexical error.
   end.

find_char_lit_end (Inp, Ch) ->
   %% There is a lexical error. Determine which kind it fits into.
   {Char, Line_no, Column_no} = Ch,
   {{Char1, _, _}, Inp1} = get_ch (Inp),
   case Char1 of
      Char -> multicharacter_literal (Line_no, Column_no);
      eof -> unterminated_character_literal (Line_no, Column_no);
      _ -> find_char_lit_end (Inp1, Ch)
   end.

%%%-------------------------------------------------------------------
%%%
%%% Character-at-a-time input, with unrestricted pushback, and with
%%% line and column numbering.
%%%

make_inp (Inpf) ->
   #inp_t{inpf = Inpf,
          pushback = [],
          line_no = 1,
          column_no = 1}.

get_ch (Inp) ->
   #inp_t{inpf = Inpf,
          pushback = Pushback,
          line_no = Line_no,
          column_no = Column_no} = Inp,
   case Pushback of
      [Ch | Tail] ->
         Inp1 = Inp#inp_t{pushback = Tail},
         {Ch, Inp1};
      [] ->
         case io:get_chars (Inpf, "", 1) of
            eof ->
               Ch = {eof, Line_no, Column_no},
               {Ch, Inp};
            {error, _} ->
               Ch = {eof, Line_no, Column_no},
               {Ch, Inp};
            Char ->
               case Char of
                  "\n" ->
                     Ch = {Char, Line_no, Column_no},
                     Inp1 = Inp#inp_t{line_no = Line_no + 1,
                                      column_no = 1},
                     {Ch, Inp1};
                  _ ->
                     Ch = {Char, Line_no, Column_no},
                     Inp1 =
                        Inp#inp_t{column_no = Column_no + 1},
                     {Ch, Inp1}
               end
         end
   end.

push_back (Ch, Inp) ->
   Inp#inp_t{pushback = [Ch | Inp#inp_t.pushback]}.

%%%-------------------------------------------------------------------

invalid_integer_literal (Line_no, Column_no, Word) ->
   error_abort ("invalid integer literal \"" ++
                   Word ++ "\" at " ++
                   integer_to_list (Line_no) ++ ":" ++
                   integer_to_list (Column_no)).

unsupported_escape (Line_no, Column_no, Char) ->
   error_abort ("unsupported escape \\" ++
                   Char ++ " at " ++
                   integer_to_list (Line_no) ++ ":" ++
                   integer_to_list (Column_no)).

unexpected_character (Line_no, Column_no, Char) ->
   error_abort ("unexpected character '" ++
                   Char ++ "' at " ++
                   integer_to_list (Line_no) ++ ":" ++
                   integer_to_list (Column_no)).

eoi_in_string_literal (Line_no, Column_no) ->
   error_abort ("end of input in string literal starting at " ++
                   integer_to_list (Line_no) ++ ":" ++
                   integer_to_list (Column_no)).

eoln_in_string_literal (Line_no, Column_no) ->
   error_abort ("end of line in string literal starting at " ++
                   integer_to_list (Line_no) ++ ":" ++
                   integer_to_list (Column_no)).

unterminated_character_literal (Line_no, Column_no) ->
   error_abort ("unterminated character literal starting at " ++
                   integer_to_list (Line_no) ++ ":" ++
                   integer_to_list (Column_no)).

multicharacter_literal (Line_no, Column_no) ->
   error_abort ("unsupported multicharacter literal starting at " ++
                   integer_to_list (Line_no) ++ ":" ++
                   integer_to_list (Column_no)).

unterminated_comment (Line_no, Column_no) ->
   error_abort ("unterminated comment starting at " ++
                   integer_to_list (Line_no) ++ ":" ++
                   integer_to_list (Column_no)).

error_abort (Message) ->
   ProgName = escript:script_name (),
   io:put_chars (standard_error, ProgName),
   io:put_chars (standard_error, ": "),
   io:put_chars (standard_error, Message),
   io:put_chars (standard_error, "\n"),
   halt (1).

%%%-------------------------------------------------------------------
%%% Instructions to GNU Emacs --
%%% local variables:
%%% mode: erlang
%%% erlang-indent-level: 3
%%% end:
%%%-------------------------------------------------------------------


include std/io.e
include std/map.e
include std/types.e
include std/convert.e

constant true = 1, false = 0, EOF = -1

enum 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

constant 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"}

integer input_file, the_ch = ' ', the_col = 0, the_line = 1
sequence symbols
map key_words = new()

procedure error(sequence format, sequence data)
    printf(STDOUT, format, data)
    abort(1)
end procedure

-- get the next character from the input
function next_ch()
    the_ch = getc(input_file)
    the_col += 1
    if the_ch = '\n' then
        the_line += 1
        the_col = 0
    end if
    return the_ch
end function

-- 'x' - character constants
function char_lit(integer err_line, integer err_col)
    integer n = next_ch()              -- skip opening quote
    if the_ch = '\'' then
        error("%d %d empty character constant", {err_line, err_col})
    elsif the_ch = '\\' then
        next_ch()
        if the_ch = 'n' then
            n = 10
        elsif the_ch = '\\' then
            n = '\\'
        else
            error("%d %d unknown escape sequence \\%c", {err_line, err_col, the_ch})
        end if
    end if
    if next_ch() != '\'' then
        error("%d %d multi-character constant", {err_line, err_col})
    end if
    next_ch()
    return {tk_Integer, err_line, err_col, n}
end function

-- process divide or comments
function div_or_cmt(integer err_line, integer err_col)
    if next_ch() != '*' then
        return {tk_Div, err_line, err_col}
    end if

    -- comment found
    next_ch()
    while true do
        if the_ch = '*' then
            if next_ch() = '/' then
                next_ch()
                return get_tok()
            end if
        elsif the_ch = EOF then
            error("%d %d EOF in comment", {err_line, err_col})
        else
            next_ch()
        end if
    end while
end function

-- "string"
function string_lit(integer start, integer err_line, integer err_col)
    string text = ""

    while next_ch() != start do
        if the_ch = EOF then
            error("%d %d EOF while scanning string literal", {err_line, err_col})
        end if
        if the_ch = '\n' then
            error("%d %d EOL while scanning string literal", {err_line, err_col})
        end if
        text &= the_ch
    end while

    next_ch()
    return {tk_String, err_line, err_col, text}
end function

-- handle identifiers and integers
function ident_or_int(integer err_line, integer err_col)
    integer n, is_number = true
    string text = ""

    while t_alnum(the_ch) or the_ch = '_' do
        text &= the_ch
        if not t_digit(the_ch) then
            is_number = false
        end if
        next_ch()
    end while

    if length(text) = 0 then
        error("%d %d ident_or_int: unrecognized character: (%d) '%s'", {err_line, err_col, the_ch, the_ch})
    end if

    if t_digit(text[1]) then
        if not is_number then
            error("%d %d invalid number: %s", {err_line, err_col, text})
        end if
        n = to_integer(text)
        return {tk_Integer, err_line, err_col, n}
    end if

    if has(key_words, text) then
        return {get(key_words, text), err_line, err_col}
    end if

    return {tk_Ident, err_line, err_col, text}
end function

-- look ahead for '>=', etc.
function follow(integer expect, integer ifyes, integer ifno, integer err_line, integer err_col)
    if next_ch() = expect then
        next_ch()
        return {ifyes, err_line, err_col}
    end if

    if ifno = tk_EOI then
        error("%d %d follow: unrecognized character: (%d)", {err_line, err_col, the_ch})
    end if

    return {ifno, err_line, err_col}
end function

-- return the next token type
function get_tok()
    while t_space(the_ch) do
        next_ch()
    end while

    integer err_line = the_line
    integer err_col  = the_col

    switch the_ch do
        case EOF  then return {tk_EOI, err_line, err_col}
        case '/'  then return div_or_cmt(err_line, err_col)
        case '\'' then return char_lit(err_line, err_col)

        case '<'  then return follow('=', tk_Leq, tk_Lss,    err_line, err_col)
        case '>'  then return follow('=', tk_Geq, tk_Gtr,    err_line, err_col)
        case '='  then return follow('=', tk_Eq,  tk_Assign, err_line, err_col)
        case '!'  then return follow('=', tk_Neq, tk_Not,    err_line, err_col)
        case '&'  then return follow('&', tk_And, tk_EOI,    err_line, err_col)
        case '|'  then return follow('|', tk_Or,  tk_EOI,    err_line, err_col)

        case '"'  then return string_lit(the_ch, err_line, err_col)
        case else
            integer sym = symbols[the_ch]
            if sym  != tk_EOI then
                next_ch()
                return {sym, err_line, err_col}
            end if
            return ident_or_int(err_line, err_col)
    end switch
end function

procedure init()
    put(key_words, "else",    tk_Else)
    put(key_words, "if",      tk_If)
    put(key_words, "print",   tk_Print)
    put(key_words, "putc",    tk_Putc)
    put(key_words, "while",   tk_While)

    symbols = repeat(tk_EOI, 256)
    symbols['{'] = tk_Lbrace
    symbols['}'] = tk_Rbrace
    symbols['('] = tk_Lparen
    symbols[')'] = tk_Rparen
    symbols['+'] = tk_Add
    symbols['-'] = tk_Sub
    symbols['*'] = tk_Mul
    symbols['%'] = tk_Mod
    symbols[';'] = tk_Semi
    symbols[','] = tk_Comma
end procedure

procedure main(sequence cl)
    sequence file_name

    input_file = STDIN
    if length(cl) > 2 then
        file_name = cl[3]
        input_file = open(file_name, "r")
        if input_file = -1 then
            error("Could not open %s", {file_name})
        end if
    end if
    init()
    sequence t
    loop do
        t = get_tok()
        printf(STDOUT, "%5d  %5d %-8s", {t[2], t[3], all_syms[t[1]]})
        switch t[1] do
            case tk_Integer then printf(STDOUT, "  %5d\n",   {t[4]})
            case tk_Ident   then printf(STDOUT, " %s\n",     {t[4]})
            case tk_String  then printf(STDOUT, " \"%s\"\n", {t[4]})
            case else            printf(STDOUT, "\n")
        end switch
        until t[1] = tk_EOI
    end loop
end procedure

main(command_line())


typedef struct oct_node_t oct_node_t, *oct_node;
struct oct_node_t{
	/* sum of all colors represented by this node. 64 bit in case of HUGE image */
	uint64_t r, g, b;
	int count, heap_idx;
	oct_node kids[8], parent;
	unsigned char n_kids, kid_idx, flags, depth;
};

/* cmp function that decides the ordering in the heap.  This is how we determine
   which octree node to fold next, the heart of the algorithm. */
inline int cmp_node(oct_node a, oct_node b)
{
	if (a->n_kids < b->n_kids) return -1;
	if (a->n_kids > b->n_kids) return 1;

	int ac = a->count * (1 + a->kid_idx) >> a->depth;
	int bc = b->count * (1 + b->kid_idx) >> b->depth;
	return ac < bc ? -1 : ac > bc;
}

/* adding a color triple to octree */
oct_node node_insert(oct_node root, unsigned char *pix)
{
#	define OCT_DEPTH 8
	/* 8: number of significant bits used for tree.  It's probably good enough
	   for most images to use a value of 5.  This affects how many nodes eventually
	   end up in the tree and heap, thus smaller values helps with both speed
	   and memory. */

	unsigned char i, bit, depth = 0;
	for (bit = 1 << 7; ++depth < OCT_DEPTH; bit >>= 1) {
		i = !!(pix[1] & bit) * 4 + !!(pix[0] & bit) * 2 + !!(pix[2] & bit);
		if (!root->kids[i])
			root->kids[i] = node_new(i, depth, root);

		root = root->kids[i];
	}

	root->r += pix[0];
	root->g += pix[1];
	root->b += pix[2];
	root->count++;
	return root;
}

/* remove a node in octree and add its count and colors to parent node. */
oct_node node_fold(oct_node p)
{
	if (p->n_kids) abort();
	oct_node q = p->parent;
	q->count += p->count;

	q->r += p->r;
	q->g += p->g;
	q->b += p->b;
	q->n_kids --;
	q->kids[p->kid_idx] = 0;
	return q;
}

/* traverse the octree just like construction, but this time we replace the pixel
   color with color stored in the tree node */
void color_replace(oct_node root, unsigned char *pix)
{
	unsigned char i, bit;

	for (bit = 1 << 7; bit; bit >>= 1) {
		i = !!(pix[1] & bit) * 4 + !!(pix[0] & bit) * 2 + !!(pix[2] & bit);
		if (!root->kids[i]) break;
		root = root->kids[i];
	}

	pix[0] = root->r;
	pix[1] = root->g;
	pix[2] = root->b;
}

/* Building an octree and keep leaf nodes in a bin heap.  Afterwards remove first node
   in heap and fold it into its parent node (which may now be added to heap), until heap
   contains required number of colors. */
void color_quant(image im, int n_colors)
{
	int i;
	unsigned char *pix = im->pix;
	node_heap heap = { 0, 0, 0 };

	oct_node root = node_new(0, 0, 0), got;
	for (i = 0; i < im->w * im->h; i++, pix += 3)
		heap_add(&heap, node_insert(root, pix));

	while (heap.n > n_colors + 1)
		heap_add(&heap, node_fold(pop_heap(&heap)));

	double c;
	for (i = 1; i < heap.n; i++) {
		got = heap.buf[i];
		c = got->count;
		got->r = got->r / c + .5;
		got->g = got->g / c + .5;
		got->b = got->b / c + .5;
		printf("%2d | %3llu %3llu %3llu (%d pixels)\n",
			i, got->r, got->g, got->b, got->count);
	}

	for (i = 0, pix = im->pix; i < im->w * im->h; i++, pix += 3)
		color_replace(root, pix);

	node_free();
	free(heap.buf);
}


%{
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <errno.h>
#include <limits.h>

#define NELEMS(arr) (sizeof(arr) / sizeof(arr[0]))

typedef enum {
    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
} TokenType;

void yyerror(char msg[]) {
    printf(msg);
    exit(1);
}

static int yynval;

struct yylloc {
    int first_line, first_col;
    int last_line, last_col;
} yylloc;

static void update_loc() {
  static int curr_line = 1;
  static int curr_col  = 1;

  yylloc.first_line = curr_line;
  yylloc.first_col  = curr_col;

  {char *s; for (s = yytext; *s != '\0'; s++) {
    if (*s == '\n') {
      curr_line++;
      curr_col = 1;
    } else {
      curr_col++;
    }
  }}

  yylloc.last_line = curr_line;
  yylloc.last_col  = curr_col-1;
}

#define YY_USER_ACTION update_loc();

static int kwd_cmp(const void *p1, const void *p2) {
    return strcmp(*(char **)p1, *(char **)p2);
}

static TokenType get_ident_type(const char *ident) {
    static struct {
        char *s;
        TokenType sym;
    } kwds[] = {
        {"else",  tk_Else},
        {"if",    tk_If},
        {"print", tk_Print},
        {"putc",  tk_Putc},
        {"while", tk_While},
    }, *kwp;

    return (kwp = bsearch(&ident, kwds, NELEMS(kwds), sizeof(kwds[0]), kwd_cmp)) == NULL ? tk_Ident : kwp->sym;
}

%}

%start COMMENT2

%option noyywrap

digit       [0-9]
ident       [a-zA-Z_][a-zA-Z_0-9]*

number       {digit}+
string       \"[^"\n]*\"
char_const   \'([^'\n]|\\n|\\\\)\'

%%

<COMMENT2>[^*]+  ;
<COMMENT2>\*[^/] ;
<COMMENT2>\*\/	 BEGIN 0;		/* end comment */
"/*"		     BEGIN COMMENT2;

"{"      {return tk_Lbrace;}
"}"      {return tk_Rbrace;}
"("      {return tk_Lparen;}
")"      {return tk_Rparen;}
"*"      {return tk_Mul;}
"/"      {return tk_Div;}
"%"      {return tk_Mod;}
"+"      {return tk_Add;}
"-"      {return tk_Sub;}
"<"      {return tk_Lss;}
">"      {return tk_Gtr;}
"<="     {return tk_Leq;}
">="     {return tk_Geq;}
"!="     {return tk_Neq;}
"!"      {return tk_Not;}
"&&"     {return tk_And;}
"||"     {return tk_Or;}
";"      {return tk_Semi;}
","      {return tk_Comma;}
"=="     {return tk_Eq;}
"="      {return tk_Assign;}
{ident}  {return get_ident_type(yytext);}
{string} {return tk_String;}

[ \t\n]+ ; /* ignore whitespace */

{number}     {
                yynval = strtol(yytext, NULL, 0);
                if (yynval == LONG_MAX && errno == ERANGE)
                    yyerror("Number exceeds maximum value");

                return tk_Integer;
             }

{char_const} {
                int n = yytext[1];
                char *p = yytext;

                if (yyleng < 3)
                    yyerror("empty character constant");
                ++p;
                if (p[0] == '\\') {
                    ++p;
                    if (p[0] == 'n')
                        n = 10;
                    else if (p[0] == '\\')
                        n = '\\';
                    else
                        yyerror("unknown escape sequence");
                }
                yynval = n;
                return tk_Integer;
             }

.            yyerror("Unknown character\n");

%%

int main(int argc, char *argv[]) {
    int tok;

    ++argv, --argc;  /* skip over program name */
    yyin = stdin;
    if (argc > 0)
        yyin = fopen(argv[0], "r");

    do {
        tok = yylex();
        printf("%5d  %5d %.15s", yylloc.first_line, yylloc.first_col,
            &"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          "
            [tok * 16]);

        if (tok == tk_Integer)     printf("   %5d", yynval);
        else if (tok == tk_Ident)  printf("  %s",   yytext);
        else if (tok == tk_String) printf("  %s",   yytext);
        printf("\n");
    } while (tok != tk_EOI);
    return 0;
}


(defpackage #:quantize
  (:use #:cl
        #:opticl))

(in-package #:quantize)

(defun image->pixels (image)
  (check-type image 8-bit-rgb-image)
  (let (pixels)
    (do-pixels (y x) image
      (push (pixel* image y x) pixels))
    pixels))

(defun greatest-color-range (pixels)
  (loop for (r g b) in pixels
        minimize r into r-min
        minimize g into g-min
        minimize b into b-min
        maximize r into r-max
        maximize g into g-max
        maximize b into b-max
        finally
           (return (let* ((r-range (- r-max r-min))
                          (g-range (- g-max g-min))
                          (b-range (- b-max b-min))
                          (max-range (max r-range g-range b-range)))
                     (cond ((= r-range max-range) 0)
                           ((= g-range max-range) 1)
                           (t                     2))))))

(defun median-cut (pixels target-num-colors)
  (assert (zerop (mod (log target-num-colors 2) 1)))
  (if (or (= target-num-colors 1) (null (rest pixels)))
      (list pixels)
      (let* ((channel (greatest-color-range pixels))
             (sorted (sort pixels #'< :key (lambda (pixel) (nth channel pixel))))
             (half (floor (length sorted) 2))
             (next-target (/ target-num-colors 2)))
        (nconc (median-cut (subseq sorted 0 half) next-target)
               (median-cut (subseq sorted half) next-target)))))

(defun quantize-colors (pixels target-num-colors)
  (let ((color-map (make-hash-table :test #'equal)))
    (dolist (bucket (median-cut pixels target-num-colors) color-map)
      (loop for (r g b) in bucket
            sum r into r-sum
            sum g into g-sum
            sum b into b-sum
            count t into num-pixels
            finally (let ((average (list (round r-sum num-pixels)
                                         (round g-sum num-pixels)
                                         (round b-sum num-pixels))))
                      (dolist (pixel bucket)
                        (setf (gethash pixel color-map) average)))))))

(defun quantize-image (input-file output-file target-num-colors)
  (let* ((image (read-png-file input-file))
         (pixels (image->pixels image))
         (color-map (quantize-colors pixels target-num-colors))
         (result-image (with-image-bounds (height width) image
                         (make-8-bit-rgb-image height width :initial-element 0))))
    (set-pixels (y x) result-image
      (let* ((original (multiple-value-list (pixel image y x)))
             (quantized (gethash original color-map)))
        (values-list quantized)))
    (write-png-file output-file result-image)))