import gtk2, gdk2, gdk2pixbuf

type Color = tuple[r, g, b: byte]

gtk2.nim_init()

proc getPixelColor(x, y: int32): Color =
  var p = pixbufNew(COLORSPACE_RGB, false, 8, 1, 1)
  discard p.getFromDrawable(getDefaultRootWindow().Drawable,
    getDefaultScreen().getSystemColormap(), x, y, 0, 0, 1, 1)
  result = cast[ptr Color](p.getPixels)[]

echo getPixelColor(0, 0)


use strict;
use warnings;
use GD;

my $file = '/tmp/one-pixel-screen-capture.png';

system "screencapture -R 123,456,1,1 $file";

my $image = GD::Image->newFromPng($file);
my $index = $image->getPixel(0,0);
my($red,$green,$blue) = $image->rgb($index);
print "RGB: $red, $green, $blue\n";

unlink $file;


$img = imagegrabscreen();
$color = imagecolorat($im, 10, 50);
imagedestroy($im);


(in '(grabc)
   (mapcar hex (cdr (line NIL 1 2 2 2))) )


void draw(){
  color c = get(mouseX,mouseY);
  println(c, red(c), green(c), blue(c));
}


def get_pixel_colour(i_x, i_y):
	import win32gui
	i_desktop_window_id = win32gui.GetDesktopWindow()
	i_desktop_window_dc = win32gui.GetWindowDC(i_desktop_window_id)
	long_colour = win32gui.GetPixel(i_desktop_window_dc, i_x, i_y)
	i_colour = int(long_colour)
	win32gui.ReleaseDC(i_desktop_window_id,i_desktop_window_dc)
	return (i_colour & 0xff), ((i_colour >> 8) & 0xff), ((i_colour >> 16) & 0xff)

print (get_pixel_colour(0, 0))


use GD::Raw;

my $file = '/tmp/one-pixel-screen-capture.png';

qqx/screencapture -R 123,456,1,1 $file/;

my $fh    = fopen($file, "rb") or die;
my $image = gdImageCreateFromPng($fh);
my $pixel = gdImageGetPixel($image, 0, 0);
my ($red,$green,$blue) =
    gdImageRed(  $image, $pixel),
    gdImageGreen($image, $pixel),
    gdImageBlue( $image, $pixel);

say "RGB: $red, $green, $blue";

fclose($fh);
unlink $file;


/*REXX program obtains the cursor position (within it's window) and displays it's color.*/
parse value  cursor()  with  r  c  .             /*get cursor's location in DOS screen. */

hue=scrRead(r, c, 1, 'A')                        /*get color of the cursor's location.  */
if hue=='00'x  then color= 'black'               /*or dark grey, dark gray.             */
if hue=='01'x  then color= 'darkblue'
if hue=='02'x  then color= 'darkgreen'
if hue=='03'x  then color= 'darkturquoise'       /*or dark cyan.                        */
if hue=='04'x  then color= 'darkred'             /*or maroon.                           */
if hue=='05'x  then color= 'darkmagenta'         /*or dark pink.                        */
if hue=='06'x  then color= 'orange'              /*or dark yellow, orage, brown.        */
if hue=='07'x  then color= 'gray'                /*or grey, gray, dark white.           */
if hue=='08'x  then color= 'gray'                /*or grey, gray, dark white.           */
if hue=='09'x  then color= 'blue'                /*or bright blue.                      */
if hue=='0A'x  then color= 'green'               /*or bright green.                     */
if hue=='0B'x  then color= 'turquoise'           /*or bright turquoise, cyan, britecyan.*/
if hue=='0C'x  then color= 'red'                 /*or bright red.                       */
if hue=='0D'x  then color= 'magenta'             /*or bright magenta, pink, brite pink. */
if hue=='0E'x  then color= 'yellow'              /*or bright yellow.                    */
if hue=='0F'x  then color= 'white'               /*or bright, brite white.              */
say 'screen location ('r","c') color is:' color  /*display color of char at row, column.*/


# Project : Color of a screen pixel

Load "gamelib.ring"
r = 0
g = 0
b = 0
al_init()
al_init_image_addon()
display = al_create_display(1000,800)
al_set_target_bitmap(al_get_backbuffer(display))
al_clear_to_color(al_map_rgb(255,255,255))
image = al_load_bitmap("stock.jpg")
al_draw_rotated_bitmap(image,0,0,250,250,150,0)
al_draw_scaled_bitmap(image,0,0,250,250,20,20,400,400,0)
ring_getpixel(image,300,300)
see "r = " + r + nl
see "g = " + g + nl
see "b = " + b + nl
al_flip_display()
al_rest(2)
al_destroy_bitmap(image)
al_destroy_display(display)

func ring_getpixel(image,x,y)
       newcolor = al_get_pixel(image,x,y)
       r=copy(" ",4)  g=copy(" ",4)  b=copy(" ",4)
       p1 = VarPtr("r","float")
       p2 = VarPtr("g","float")
       p3 = VarPtr("b","float")
       al_unmap_rgb_f(newcolor, p1 , p2 , p3 )
       r = bytes2float(r)
       g = bytes2float(g)
       b = bytes2float(b)
       return [r,g,b]


module Screen
  IMPORT_COMMAND = '/usr/bin/import'

  # Returns an array with RGB values for the pixel at the given coords
  def self.pixel(x, y)
    if m = `#{IMPORT_COMMAND} -silent -window root -crop 1x1+#{x.to_i}+#{y.to_i} -depth 8 txt:-`.match(/\((\d+),(\d+),(\d+)\)/)
      m[1..3].map(&:to_i)
    else
      false
    end
  end
end


def getColorAt(x: Int, y: Int): Color = new Robot().getPixelColor(x, y)


Display rootView colorAt:(10@10).
Display rootView colorAt:(Display pointerPosition)


open XWindows ;
val disp =  XOpenDisplay "" ;

val im =
let
   val pos =  #4 (XQueryPointer (RootWindow disp)) ;
in
   XGetImage (RootWindow disp) (MakeRect pos (AddPoint(pos,XPoint{x=1,y=1})) ) AllPlanes ZPixmap
end;

 XGetPixel disp im (XPoint {x=0,y=0}) ;


package require Tcl 8.5
package require Tk

# Farm out grabbing the screen to an external program.
# If it was just for a Tk window, we'd use the tkimg library instead
proc grabScreen {image} {
    set pipe [open {|xwd -root -silent | convert xwd:- ppm:-} rb]
    $image put [read $pipe]
    close $pipe
}
# Get the RGB data for a particular pixel (global coords)
proc getPixelAtPoint {x y} {
    set buffer [image create photo]
    grabScreen $buffer
    set data [$image get $x $y]
    image delete $buffer
    return $data
}

# Demo...
puts [format "pixel at mouse: (%d,%d,%d)" \
    {*}[getPixelAtPoint {*}[winfo pointerxy .]]]


import "dome" for Window, Process
import "graphics" for Canvas, Color
import "input" for Mouse

class Game {
    static init() {
        Window.title = "Color of a screen pixel"
        Canvas.cls(Color.orange) // {255, 163, 0} in the default palette
    }

    static update() {
        // report location and color of pixel at mouse cursor
        // when the left button is first pressed
        if (Mouse.isButtonPressed("left")) {
            var x = Mouse.x
            var y = Mouse.y
            var col = Canvas.pget(x, y)
            System.print("The color of the pixel at (%(x), %(y)) is %(getRGB(col))")
            Process.exit(0)
        }
    }

    static draw(dt) {}

    static getRGB(col) { "{%(col.r), %(col.g), %(col.b)}" }
}


code ReadPix=44;
int  Color, X, Y;
Color:= ReadPix(X, Y);


with Ada.Text_IO, Ada.Streams.Stream_IO, Ada.Strings.Unbounded, Ada.Command_Line,
     Ada.Exceptions;
use Ada.Strings, Ada.Strings.Unbounded, Ada.Streams, Ada.Exceptions;

procedure Main is
   package IO renames Ada.Text_IO;

   package Lexer is
      type Token is (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, Token_Integer, Token_String, End_of_input,

                     Empty_Char_Error, Invalid_Escape_Error, Multi_Char_Error, EOF_Comment_Error,
                     EOF_String_Error, EOL_String_Error, Invalid_Char_Error, Invalid_Num_Error
                    );

      subtype Operator is Token range Op_multiply .. Op_or;
      subtype Symbol is Token range Token'Succ(Operator'Last) .. Comma;
      subtype Keyword is Token range Token'Succ(Symbol'Last) .. Keyword_putc;
      subtype Error is Token range Empty_Char_Error .. Invalid_Num_Error;
      subtype Operator_or_Error is Token
        with Static_Predicate => Operator_or_Error in Operator | Error;

      subtype Whitespace is Character
        with Static_Predicate => Whitespace in ' ' | ASCII.HT | ASCII.CR | ASCII.LF;

      Lexer_Error : exception;
      Invalid_Escape_Code : constant Character := ASCII.NUL;

      procedure run(input : Stream_IO.File_Type);
   end Lexer;

   package body Lexer is
      use type Stream_IO.Count;

      procedure run(input : Stream_IO.File_Type) is
         type State is (State_Start, State_Identifier, State_Integer, State_Char, State_String,
                        State_Comment);
         curr_state : State := State_Start;
         curr_char : Character;
         curr_col, curr_row, token_col, token_row : Positive := 1;
         token_text : Unbounded_String := Unbounded.Null_Unbounded_String;

         function look_ahead return Character is
            next_char : Character := ASCII.LF;
         begin
            if not Stream_IO.End_Of_File(input) then
               next_char := Character'Input(Stream_IO.Stream(input));
               Stream_IO.Set_Index(input, Stream_IO.Index(input) - 1);
            end if;
            return next_char;
         end look_ahead;

         procedure next_char is
            next : Character := Character'Input(Stream_IO.Stream(input));
         begin
            curr_col := curr_col + 1;
            if curr_char = ASCII.LF then
               curr_row := curr_row + 1;
               curr_col := 1;
            end if;
            curr_char := next;
         end next_char;

         procedure print_token(tok : Token; text : String := "") is
            procedure raise_error(text : String) is
            begin
               raise Lexer_Error with "Error: " & text;
            end;
         begin
            IO.Put(token_row'Image & ASCII.HT & token_col'Image & ASCII.HT);
            case tok is
               when Operator | Symbol | Keyword | End_of_input => IO.Put_Line(tok'Image);
               when Token_Integer => IO.Put_Line("INTEGER" & ASCII.HT & text);
               when Token_String  => IO.Put_Line("STRING" & ASCII.HT & ASCII.Quotation & text & ASCII.Quotation);
               when Identifier    => IO.Put_Line(tok'Image & ASCII.HT & text);
               when Empty_Char_Error => raise_error("empty character constant");
               when Invalid_Escape_Error => raise_error("unknown escape sequence: " & text);
               when Multi_Char_Error => raise_error("multi-character constant: " & text);
               when EOF_Comment_Error => raise_error("EOF in comment");
               when EOF_String_Error => raise_error("EOF in string");
               when EOL_String_Error => raise_error("EOL in string");
               when Invalid_Char_Error => raise_error("invalid character: " & curr_char);
               when Invalid_Num_Error => raise_error("invalid number: " & text);
            end case;
         end print_token;

         procedure lookahead_choose(determiner : Character; a, b : Operator_or_Error) is
         begin
            if look_ahead = determiner then
               print_token(a);
               next_char;
            else
               print_token(b);
            end if;
         end lookahead_choose;

         function to_escape_code(c : Character) return Character is
         begin
            case c is
               when 'n' => return ASCII.LF;
               when '\' => return '\';
               when others =>
                  print_token(Invalid_Escape_Error, ASCII.Back_Slash & c);
                  return Invalid_Escape_Code;
            end case;
         end to_escape_code;
      begin
         curr_char := Character'Input(Stream_IO.Stream(input));
         loop
            case curr_state is
               when State_Start =>
                  token_col := curr_col;
                  token_row := curr_row;
                  case curr_char is
                     when '*' => print_token(Op_multiply);
                     when '/' =>
                        if look_ahead = '*' then
                           next_char;
                           curr_state := State_Comment;
                        else
                           print_token(Op_divide);
                        end if;
                     when '%' => print_token(Op_mod);
                     when '+' => print_token(Op_add);
                     when '-' => print_token(Op_subtract);
                     when '(' => print_token(LeftParen);
                     when ')' => print_token(RightParen);
                     when '{' => print_token(LeftBrace);
                     when '}' => print_token(RightBrace);
                     when ';' => print_token(Semicolon);
                     when ',' => print_token(Comma);
                     when '<' => lookahead_choose('=', Op_lessequal, Op_less);
                     when '>' => lookahead_choose('=', Op_greaterequal, Op_greater);
                     when '!' => lookahead_choose('=', Op_notequal, Op_not);
                     when '=' => lookahead_choose('=', Op_equal, Op_assign);
                     when '&' => lookahead_choose('&', Op_and, Invalid_Char_Error);
                     when '|' => lookahead_choose('|', Op_or, Invalid_Char_Error);
                     when 'a' .. 'z' | 'A' .. 'Z' | '_' =>
                        Unbounded.Append(token_text, curr_char);
                        curr_state := State_Identifier;
                     when '0' .. '9' =>
                        Unbounded.Append(token_text, curr_char);
                        curr_state := State_Integer;
                     when ''' => curr_state := State_Char;
                     when ASCII.Quotation => curr_state := State_String;
                     when Whitespace => null;
                     when others => null;
                  end case;
                  next_char;

               when State_Identifier =>
                  case curr_char is
                     when 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' =>
                        Unbounded.Append(token_text, curr_char);
                        next_char;
                     when others =>
                        if token_text = "if" then
                           print_token(Keyword_if);
                        elsif token_text = "else" then
                           print_token(Keyword_else);
                        elsif token_text = "while" then
                           print_token(Keyword_while);
                        elsif token_text = "print" then
                           print_token(Keyword_print);
                        elsif token_text = "putc" then
                           print_token(Keyword_putc);
                        else
                           print_token(Identifier, To_String(token_text));
                        end if;
                        Unbounded.Set_Unbounded_String(token_text, "");
                        curr_state := State_Start;
                  end case;

               when State_Integer =>
                  case curr_char is
                     when '0' .. '9' =>
                        Unbounded.Append(token_text, curr_char);
                        next_char;
                     when 'a' .. 'z' | 'A' .. 'Z' | '_' =>
                        print_token(Invalid_Num_Error, To_String(token_text));
                     when others =>
                        print_token(Token_Integer, To_String(token_text));
                        Unbounded.Set_Unbounded_String(token_text, "");
                        curr_state := State_Start;
                  end case;

               when State_Char =>
                  case curr_char is
                     when ''' =>
                        if Unbounded.Length(token_text) = 0 then
                           print_token(Empty_Char_Error);
                        elsif Unbounded.Length(token_text) = 1 then
                           print_token(Token_Integer, Character'Pos(Element(token_text, 1))'Image);
                        else
                           print_token(Multi_Char_Error, To_String(token_text));
                        end if;
                        Set_Unbounded_String(token_text, "");
                        curr_state := State_Start;
                     when '\' =>
                        Unbounded.Append(token_text, to_escape_code(look_ahead));
                        next_char;
                     when others => Unbounded.Append(token_text, curr_char);
                  end case;
                  next_char;

               when State_String =>
                  case curr_char is
                     when ASCII.Quotation =>
                        print_token(Token_String, To_String(token_text));
                        Set_Unbounded_String(token_text, "");
                        curr_state := State_Start;
                     when '\' =>
                        if to_escape_code(look_ahead) /= Invalid_Escape_Code then
                           Unbounded.Append(token_text, curr_char);
                        end if;
                     when ASCII.LF | ASCII.CR => print_token(EOL_String_Error);
                     when others => Unbounded.Append(token_text, curr_char);
                  end case;
                  next_char;

               when State_Comment =>
                  case curr_char is
                     when '*' =>
                        if look_ahead = '/' then
                           next_char;
                           curr_state := State_Start;
                        end if;
                     when others => null;
                  end case;
                  next_char;
            end case;
         end loop;
      exception
         when error : Stream_IO.End_Error =>
            if curr_state = State_String then
               print_token(EOF_String_Error);
            else
               print_token(End_of_input);
            end if;
         when error : Lexer.Lexer_Error => IO.Put_Line(Exception_Message(error));
      end run;
   end Lexer;

   source_file : Stream_IO.File_Type;
begin
   if Ada.Command_Line.Argument_Count < 1 then
      IO.Put_Line("usage: lex [filename]");
      return;
   end if;
   Stream_IO.Open(source_file, Stream_IO.In_File, Ada.Command_Line.Argument(1));
   Lexer.run(source_file);
exception
   when error : others => IO.Put_Line("Error: " & Exception_Message(error));
end Main;


BEGIN
  # implement C-like getchar, where EOF and EOLn are "characters" (-1 and 10 resp.). #
  INT eof = -1, eoln = 10;
  BOOL eof flag := FALSE;
  STRING buf := "";
  INT col := 1;
  INT line := 0;
  on logical file end (stand in, (REF FILE f)BOOL: eof flag := TRUE);
  PROC getchar = INT:
    IF   eof flag      THEN eof
    ELIF col = UPB buf THEN col +:= 1; eoln
    ELIF col > UPB buf THEN IF line > 0 THEN read(newline) FI;
                            line +:= 1;
                            read(buf);
                            IF eof flag THEN col := 1; eof
                            ELSE col := 0; getchar
                            FI
    ELSE col +:= 1; ABS buf[col]
    FI;
  PROC nextchar = INT: IF eof flag THEN eof ELIF col >= UPB buf THEN eoln ELSE ABS buf[col+1] FI;

  PROC is blank = (INT ch) BOOL: ch = 0 OR ch = 9 OR ch = 10 OR ch = 13 OR ch = ABS " ";
  PROC is digit = (INT ch) BOOL: ch >= ABS "0" AND ch <= ABS "9";
  PROC is ident start = (INT ch) BOOL: ch >= ABS "A" AND ch <= ABS "Z" OR
                                       ch >= ABS "a" AND ch <= ABS "z" OR
                                       ch = ABS "_";
  PROC is ident = (INT ch) BOOL: is ident start(ch) OR is digit(ch);

  PROC ident or keyword = (INT start char) VOID:
    BEGIN
      STRING w := REPR start char;
      INT start col = col;
      WHILE is ident (next char) DO w +:= REPR getchar OD;
      IF   w = "if"    THEN output2("Keyword_if", start col)
      ELIF w = "else"  THEN output2("Keyword_else", start col)
      ELIF w = "while" THEN output2("Keyword_while", start col)
      ELIF w = "print" THEN output2("Keyword_print", start col)
      ELIF w = "putc"  THEN output2("Keyword_putc", start col)
      ELSE output2("Identifier " + w, start col)
      FI
    END;
  PROC char = VOID:
    BEGIN
      INT start col = col;
      INT ch := getchar;
      IF   ch = ABS "'" THEN error("Empty character constant")
      ELIF ch = ABS "\" THEN ch := getchar;
                             IF   ch = ABS "n" THEN ch := 10
                             ELIF ch = ABS "\" THEN SKIP
                             ELSE error("Unknown escape sequence. \" + REPR ch)
                             FI
      FI;
      IF nextchar /= ABS "'" THEN error("Multi-character constant.") FI;
      getchar;
      output2("Integer " + whole(ch, 0), start col)
    END;
  PROC string = VOID:
    BEGIN
      INT start col = col;
      STRING s := """";
      WHILE INT ch := getchar; ch /= ABS """"
      DO
        IF   ch = eoln     THEN error("End-of-line while scanning string literal. Closing string character not found before end-of-line.")
        ELIF ch = eof      THEN error("End-of-file while scanning string literal. Closing string character not found.")
        ELIF ch = ABS "\"  THEN s +:= REPR ch; ch := getchar;
                                IF ch /= ABS "\" AND ch /= ABS "n" THEN error("Unknown escape sequence. \" + REPR ch) FI;
                                s +:= REPR ch
        ELSE s +:= REPR ch
        FI
      OD;
      output2("String " + s + """", start col)
    END;
  PROC comment = VOID:
    BEGIN
      WHILE INT ch := getchar; NOT (ch = ABS "*" AND nextchar = ABS "/")
      DO IF ch = eof THEN error("End-of-file in comment. Closing comment characters not found.") FI
      OD;
      getchar
    END;
  PROC number = (INT first digit) VOID:
    BEGIN
      INT start col = col;
      INT n := first digit - ABS "0";
      WHILE is digit (nextchar) DO
        INT u := getchar - ABS "0";
        IF LENG n * 10 + LENG u > max int THEN error("Integer too big") FI;
        n := n * 10 + u
      OD;
      IF is ident start (nextchar) THEN error("Invalid number. Starts like a number, but ends in non-numeric characters.") FI;
      output2("Integer " + whole(n, 0), start col)
    END;

  PROC output  = (STRING s) VOID: output2(s, col);
  PROC output2 = (STRING s, INT col) VOID: print((whole(line,-8), whole(col,-8), "  ", s, newline));

  PROC if follows = (CHAR second, STRING longer, shorter) VOID:
    IF nextchar = ABS second
    THEN output(longer); getchar
    ELSE output(shorter)
    FI;
  PROC error = (STRING s)VOID: (put(stand error, ("At ", whole(line,0), ":", whole(col,0), " ", s, new line)); stop);
  PROC unrecognized = (INT char) VOID: error("Unrecognized character " + REPR char);
  PROC double char = (INT first, STRING op) VOID:
    IF nextchar /= first THEN unrecognized(first)
    ELSE output2(op, col-1); getchar
    FI;

  WHILE INT ch := getchar; ch /= eof
  DO
    IF   is blank(ch) THEN SKIP
    ELIF ch = ABS "(" THEN output("LeftParen")
    ELIF ch = ABS ")" THEN output("RightParen")
    ELIF ch = ABS "{" THEN output("LeftBrace")
    ELIF ch = ABS "}" THEN output("RightBrace")
    ELIF ch = ABS ";" THEN output("Semicolon")
    ELIF ch = ABS "," THEN output("Comma")
    ELIF ch = ABS "*" THEN output("Op_multiply")
    ELIF ch = ABS "/" THEN IF next char = ABS "*" THEN comment
                           ELSE output("Op_divide")
                           FI
    ELIF ch = ABS "%" THEN output("Op_mod")
    ELIF ch = ABS "+" THEN output("Op_add")
    ELIF ch = ABS "-" THEN output("Op_subtract")
    ELIF ch = ABS "<" THEN if follows("=", "Op_lessequal", "Op_less")
    ELIF ch = ABS ">" THEN if follows("=", "Op_greaterequal", "Op_greater")
    ELIF ch = ABS "=" THEN if follows("=", "Op_equal", "Op_assign")
    ELIF ch = ABS "!" THEN if follows("=", "Op_notequal", "Op_not")
    ELIF ch = ABS "&" THEN double char(ch, "Op_and")
    ELIF ch = ABS "|" THEN double char(ch, "Op_or")
    ELIF is ident start (ch) THEN ident or keyword (ch)
    ELIF ch = ABS """" THEN string
    ELIF ch = ABS "'" THEN char
    ELIF is digit(ch) THEN number(ch)
    ELSE unrecognized(ch)
    FI
  OD;
  output("End_Of_Input")
END


begin
    %lexical analyser %
    % Algol W strings are limited to 256 characters in length so we limit source lines %
    % and tokens to 256 characters %

    integer     lineNumber, columnNumber;
    string(256) line;
    string(256) tkValue;
    integer     tkType, tkLine, tkColumn, tkLength, tkIntegerValue;
    logical     tkTooLong;
    string(1)   currChar;
    string(1)   newlineChar;

    integer     LINE_WIDTH, MAX_TOKEN_LENGTH, MAXINTEGER_OVER_10, MAXINTEGER_MOD_10;
    integer     tOp_multiply   , tOp_divide        , tOp_mod       , tOp_add
          ,     tOp_subtract   , tOp_negate        , tOp_less      , tOp_lessequal
          ,     tOp_greater    , tOp_greaterequal  , tOp_equal     , tOp_notequal
          ,     tOp_not        , tOp_assign        , tOp_and       , tOp_or
          ,     tLeftParen     , tRightParen       , tLeftBrace    , tRightBrace
          ,     tSemicolon     , tComma            , tKeyword_if   , tKeyword_else
          ,     tKeyword_while , tKeyword_print    , tKeyword_putc , tIdentifier
          ,     tInteger       , tString           , tEnd_of_input , tComment
          ;

    string(16)  array tkName ( 1 :: 32 );

    % reports an error %
    procedure lexError( string(80) value message ); begin
        integer errorPos;
        write( i_w := 1, s_w := 0, "**** Error at(", lineNumber, ",", columnNumber, "): " );
        errorPos := 0;
        while errorPos < 80 and message( errorPos // 1 ) not = "." do begin
            writeon( s_w := 0, message( errorPos // 1 ) );
            errorPos := errorPos + 1
        end while_not_at_end_of_message ;
        writeon( s_w := 0, "." )
    end lexError ;

    % gets the next source character %
    procedure nextChar ; begin
        if      columnNumber = LINE_WIDTH then begin
            currChar     := newlineChar;
            columnNumber := columnNumber + 1
            end
        else if columnNumber > LINE_WIDTH then begin
            readcard( line );
            columnNumber := 1;
            if not XCPNOTED(ENDFILE) then lineNumber := lineNumber + 1;
            currChar     := line( 0 // 1 )
            end
        else begin
            currChar     := line( columnNumber // 1 );
            columnNumber := columnNumber + 1
        end
    end nextChar ;

    % gets the next token, returns the token type %
    integer procedure nextToken ; begin

        % returns true if currChar is in the inclusive range lowerValue to upperValue %
        %         false otherwise %
        logical procedure range( string(1) value lowerValue, upperValue ) ; begin
            currChar >= lowerValue and currChar <= upperValue
        end range ;

        % returns true if the current character can start an identifier, false otherwise %
        logical procedure identifierStartChar ; begin
            currChar = "_" or range( "a", "z" ) or range( "A", "Z" )
        end identifierStartChar ;

        % add the current character to the token and get the next %
        procedure addAndNextChar ; begin
            if tkLength >= MAX_TOKEN_LENGTH then tkTooLong := true
            else begin
                tkValue( tkLength // 1 ) := currChar;
                tkLength                 := tkLength + 1
            end if_symbol_not_too_long ;
            nextChar
        end % addAndNextChar % ;

        % handle a single character token %
        procedure singleCharToken( integer value tokenType ) ; begin
            tkType := tokenType;
            nextChar
        end singleCharToken ;

        % handle a doubled character token: && or || %
        procedure doubleCharToken( integer value tokenType ) ; begin
            string(1) firstChar;
            firstChar := currChar;
            tkType    := tokenType;
            nextChar;
            if currChar = firstChar then nextChar
            else % the character wasn't doubled % lexError( "Unrecognised character." );
        end singleCharToken ;

        % handle an operator or operator= token %
        procedure opOrOpEqual( integer value opToken, opEqualToken ) ; begin
            tkType := opToken;
            nextChar;
            if currChar = "=" then begin
                % have operator= %
                tkType := opEqualToken;
                nextChar
            end if_currChar_is_equal ;
        end opOrOpEqual ;

        % handle a / operator or /* comment %
        procedure divideOrComment ; begin
            tkType := tOp_divide;
            nextChar;
            if currChar = "*" then begin
                % have a comment %
                logical moreComment;
                tkType      := tComment;
                moreComment := true;
                while moreComment do begin
                    nextChar;
                    while currChar not = "*" and not XCPNOTED(ENDFILE) do nextChar;
                    while currChar     = "*" and not XCPNOTED(ENDFILE) do nextChar;
                    moreComment := ( currChar not = "/" and not XCPNOTED(ENDFILE) )
                end while_more_comment ;
                if not XCPNOTED(ENDFILE)
                then nextChar
                else lexError( "End-of-file in comment." )
            end if_currChar_is_star ;
        end divideOrComment ;

        % handle an indentifier or keyword %
        procedure identifierOrKeyword ; begin
            tkType := tIdentifier;
            while identifierStartChar or range( "0", "9" ) do addAndNextChar;
            % there are only 5 keywords, so we just test each in turn here %
            if      tkValue = "if"      then tkType  := tKeyword_if
            else if tkValue = "else"    then tkType  := tKeyword_else
            else if tkValue = "while"   then tkType  := tKeyword_while
            else if tkValue = "print"   then tkType  := tKeyword_print
            else if tkValue = "putc"    then tkType  := tKeyword_putc;
            if tkType not = tIdentifier then tkValue := "";
        end identifierOrKeyword ;

        % handle an integer literal %
        procedure integerLiteral ; begin
            logical overflowed;
            integer digit;
            overflowed := false;
            tkType     := tInteger;
            while range( "0", "9" ) do begin
                digit := ( decode( currChar ) - decode( "0" ) );
                if      tkIntegerValue > MAXINTEGER_OVER_10 then overflowed := true
                else if tkIntegerValue = MAXINTEGER_OVER_10
                    and digit          > MAXINTEGER_MOD_10  then overflowed := true
                else begin
                    tkIntegerValue := tkIntegerValue * 10;
                    tkIntegerValue := tkIntegerValue + digit;
                end;
                nextChar
            end while_have_a_digit ;
            if overflowed          then lexError( "Number too large." );
            if identifierStartChar then lexError( "Number followed by letter or underscore." );
        end integerLiteral ;

        % handle a char literal %
        procedure charLiteral ; begin
            nextChar;
            if      currChar = "'" or currChar = newlineChar then lexError( "Invalid character constant." )
            else if currChar = "\" then begin
                % have an escape %
                nextChar;
                if      currChar     = "n" then currChar := newlineChar
                else if currChar not = "\" then lexError( "Unknown escape sequence." )
            end;
            tkType         := tInteger;
            tkIntegerValue := decode( currChar );
            % should have a closing quoute next %
            nextChar;
            if   currChar not = "'"
            then lexError( "Multi-character constant." )
            else nextChar
        end charLiteral ;

        % handle a string literal %
        procedure stringLiteral ; begin
            tkType            := tString;
            tkValue( 0 // 1 ) := currChar;
            tkLength          := 1;
            nextChar;
            while currChar not = """" and currChar not = newlineChar and not XCPNOTED(ENDFILE) do addAndNextChar;
            if      currChar = newlineChar then lexError( "End-of-line while scanning string literal." )
            else if XCPNOTED(ENDFILE)      then lexError( "End-of-file while scanning string literal." )
            else    % currChar must be """" % addAndNextChar
        end stringLiteral ;

        while begin
            % skip white space %
            while ( currChar = " " or currChar = newlineChar ) and not XCPNOTED(ENDFILE) do nextChar;
            % get the token %
            tkLine         := lineNumber;
            tkColumn       := columnNumber;
            tkValue        := "";
            tkLength       := 0;
            tkIntegerValue := 0;
            tkTooLong      := false;
            if      XCPNOTED(ENDFILE)   then tkType := tEnd_of_input
            else if currChar = "*"      then singleCharToken( tOp_multiply )
            else if currChar = "/"      then divideOrComment
            else if currChar = "%"      then singleCharToken( tOp_mod      )
            else if currChar = "+"      then singleCharToken( tOp_add )
            else if currChar = "-"      then singleCharToken( tOp_subtract )
            else if currChar = "<"      then opOrOpEqual( tOp_less,    tOp_lessequal     )
            else if currChar = ">"      then opOrOpEqual( tOp_greater, tOp_greaterequal  )
            else if currChar = "="      then opOrOpEqual( tOp_assign,  tOp_equal         )
            else if currChar = "!"      then opOrOpEqual( tOp_not,     tOp_notequal      )
            else if currChar = "&"      then doubleCharToken( tOp_and     )
            else if currChar = "|"      then doubleCharToken( tOp_or      )
            else if currChar = "("      then singleCharToken( tLeftParen  )
            else if currChar = ")"      then singleCharToken( tRightParen )
            else if currChar = "{"      then singleCharToken( tLeftBrace  )
            else if currChar = "}"      then singleCharToken( tRightBrace )
            else if currChar = ";"      then singleCharToken( tSemicolon  )
            else if currChar = ","      then singleCharToken( tComma      )
            else if identifierStartChar then identifierOrKeyword
            else if range( "0", "9" )   then integerLiteral
            else if currChar = "'"      then charLiteral
            else if currChar = """"     then stringLiteral
            else begin
                lexError( "Unrecognised character." );
                singleCharToken( tComment )
            end ;
            % continue until we get something other than a comment %
            tkType = tComment
        end do begin end;
        if tkTooLong then if   tkType = tString
                          then lexError( "String literal too long." )
                          else lexError( "Identifier too long."     );
        tkType
    end nextToken ;

    % outputs the current token %
    procedure writeToken ; begin
        write( i_w := 5, s_w := 2, tkLine, tkColumn, tkName( tkType ) );
        if tkType = tInteger then writeon( i_w := 11, tkIntegerValue )
        else if tkLength > 0 then begin
            writeon( "  " );
            for tkPos := 0 until tkLength - 1 do writeon( s_w := 0, tkValue( tkPos // 1 ) );
        end
    end writeToken ;

    LINE_WIDTH       := 256; MAXINTEGER_MOD_10  := MAXINTEGER rem 10;
    MAX_TOKEN_LENGTH := 256; MAXINTEGER_OVER_10 := MAXINTEGER div 10;
    newlineChar      := code( 10 );
    tOp_multiply     :=  1; tkName( tOp_multiply     ) := "Op_multiply";
    tOp_divide       :=  2; tkName( tOp_divide       ) := "Op_divide";
    tOp_mod          :=  3; tkName( tOp_mod          ) := "Op_mod";
    tOp_add          :=  4; tkName( tOp_add          ) := "Op_add";
    tOp_subtract     :=  5; tkName( tOp_subtract     ) := "Op_subtract";
    tOp_negate       :=  6; tkName( tOp_negate       ) := "Op_negate";
    tOp_less         :=  7; tkName( tOp_less         ) := "Op_less";
    tOp_lessequal    :=  8; tkName( tOp_lessequal    ) := "Op_lessequal";
    tOp_greater      :=  9; tkName( tOp_greater      ) := "Op_greater";
    tOp_greaterequal := 10; tkName( tOp_greaterequal ) := "Op_greaterequal";
    tOp_equal        := 11; tkName( tOp_equal        ) := "Op_equal";
    tOp_notequal     := 12; tkName( tOp_notequal     ) := "Op_notequal";
    tOp_not          := 13; tkName( tOp_not          ) := "Op_not";
    tOp_assign       := 14; tkName( tOp_assign       ) := "Op_assign";
    tOp_and          := 15; tkName( tOp_and          ) := "Op_and";
    tOp_or           := 16; tkName( tOp_or           ) := "Op_or";
    tLeftParen       := 17; tkName( tLeftParen       ) := "LeftParen";
    tRightParen      := 18; tkName( tRightParen      ) := "RightParen";
    tLeftBrace       := 19; tkName( tLeftBrace       ) := "LeftBrace";
    tRightBrace      := 20; tkName( tRightBrace      ) := "RightBrace";
    tSemicolon       := 21; tkName( tSemicolon       ) := "Semicolon";
    tComma           := 22; tkName( tComma           ) := "Comma";
    tKeyword_if      := 23; tkName( tKeyword_if      ) := "Keyword_if";
    tKeyword_else    := 24; tkName( tKeyword_else    ) := "Keyword_else";
    tKeyword_while   := 25; tkName( tKeyword_while   ) := "Keyword_while";
    tKeyword_print   := 26; tkName( tKeyword_print   ) := "Keyword_print";
    tKeyword_putc    := 27; tkName( tKeyword_putc    ) := "Keyword_putc";
    tIdentifier      := 28; tkName( tIdentifier      ) := "Identifier";
    tInteger         := 29; tkName( tInteger         ) := "Integer";
    tString          := 30; tkName( tString          ) := "String";
    tEnd_of_input    := 31; tkName( tEnd_of_input    ) := "End_of_input";
    tComment         := 32; tkName( tComment         ) := "Comment";

    % allow the program to continue after reaching end-of-file %
    ENDFILE := EXCEPTION( false, 1, 0, false, "EOF" );
    % ensure the first call to nextToken reads the first line %
    lineNumber   := 0;
    columnNumber := LINE_WIDTH + 1;
    currChar     := " ";
    % get and print all tokens from standard input %
    while nextToken not = tEnd_of_input do writeToken;
    writeToken
end.


(********************************************************************)
(* Usage: lex [INPUTFILE [OUTPUTFILE]]
   If INPUTFILE or OUTPUTFILE is "-" or missing, then standard input
   or standard output is used, respectively. *)

#define ATS_DYNLOADFLAG 0

#include "share/atspre_staload.hats"
staload UN = "prelude/SATS/unsafe.sats"

#define NIL list_nil ()
#define ::  list_cons

%{^
/* alloca(3) is needed for ATS exceptions. */
#include <alloca.h>
%}

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

#define NUM_TOKENS 31
#define RESERVED_WORD_HASHTAB_SIZE 9

#define TOKEN_ELSE          0
#define TOKEN_IF            1
#define TOKEN_PRINT         2
#define TOKEN_PUTC          3
#define TOKEN_WHILE         4
#define TOKEN_MULTIPLY      5
#define TOKEN_DIVIDE        6
#define TOKEN_MOD           7
#define TOKEN_ADD           8
#define TOKEN_SUBTRACT      9
#define TOKEN_NEGATE       10
#define TOKEN_LESS         11
#define TOKEN_LESSEQUAL    12
#define TOKEN_GREATER      13
#define TOKEN_GREATEREQUAL 14
#define TOKEN_EQUAL        15
#define TOKEN_NOTEQUAL     16
#define TOKEN_NOT          17
#define TOKEN_ASSIGN       18
#define TOKEN_AND          19
#define TOKEN_OR           20
#define TOKEN_LEFTPAREN    21
#define TOKEN_RIGHTPAREN   22
#define TOKEN_LEFTBRACE    23
#define TOKEN_RIGHTBRACE   24
#define TOKEN_SEMICOLON    25
#define TOKEN_COMMA        26
#define TOKEN_IDENTIFIER   27
#define TOKEN_INTEGER      28
#define TOKEN_STRING       29
#define TOKEN_END_OF_INPUT 30

typedef token_t =
  [i : int | TOKEN_ELSE <= i; i <= TOKEN_END_OF_INPUT]
  int i
typedef tokentuple_t = (token_t, String, ullint, ullint)
typedef token_names_vt = @[string][NUM_TOKENS]

vtypedef reserved_words_vt =
  @[String][RESERVED_WORD_HASHTAB_SIZE]
vtypedef reserved_word_tokens_vt =
  @[token_t][RESERVED_WORD_HASHTAB_SIZE]

vtypedef lookups_vt =
  [p_toknames : addr]
  [p_wordtab  : addr]
  [p_toktab   : addr]
  @{
    pf_toknames = token_names_vt @ p_toknames,
    pf_wordtab = reserved_words_vt @ p_wordtab,
    pf_toktab = reserved_word_tokens_vt @ p_toktab |
    toknames = ptr p_toknames,
    wordtab = ptr p_wordtab,
    toktab = ptr p_toktab
  }

fn
reserved_word_lookup
          (s         : String,
           lookups   : !lookups_vt,
           line_no   : ullint,
           column_no : ullint) : tokentuple_t =
  if string_length s < 2 then
    (TOKEN_IDENTIFIER, s, line_no, column_no)
  else
    let
      macdef wordtab = !(lookups.wordtab)
      macdef toktab = !(lookups.toktab)
      val hashval =
        g1uint_mod (g1ofg0 (char2ui s[0] + char2ui s[1]),
                    g1i2u RESERVED_WORD_HASHTAB_SIZE)
      val token = toktab[hashval]
    in
      if token = TOKEN_IDENTIFIER || s <> wordtab[hashval] then
        (TOKEN_IDENTIFIER, s, line_no, column_no)
      else
        (token, s, line_no, column_no)
    end

(********************************************************************)
(* Input allows pushback into a buffer. *)

typedef ch_t =
  @{
    ichar = int,
    line_no = ullint,
    column_no = ullint
  }

typedef inp_t (n : int) =
  [0 <= n]
  @{
    file = FILEref,
    pushback = list (ch_t, n),
    line_no = ullint,
    column_no = ullint
  }
typedef inp_t = [n : int] inp_t n

fn
get_ch (inp : inp_t) : (ch_t, inp_t) =
  case+ (inp.pushback) of
  | NIL =>
    let
      val c = fileref_getc (inp.file)
      val ch =
        @{
          ichar = c,
          line_no = inp.line_no,
          column_no = inp.column_no
        }
    in
      if c = char2i '\n' then
        let
          val inp =
            @{
              file = inp.file,
              pushback = inp.pushback,
              line_no = succ (inp.line_no),
              column_no = 1ULL
            }
        in
          (ch, inp)
        end
      else
        let
          val inp =
            @{
              file = inp.file,
              pushback = inp.pushback,
              line_no = inp.line_no,
              column_no = succ (inp.column_no)
            }
        in
          (ch, inp)
        end
    end
  | ch :: pushback =>
    let
      val inp =
        @{
          file = inp.file,
          pushback = pushback,
          line_no = inp.line_no,
          column_no = inp.column_no
        }
    in
      (ch, inp)
    end

fn
push_back_ch (ch  : ch_t,
              inp : inp_t) : [n : pos] inp_t n =
  let
    prval _ = lemma_list_param (inp.pushback)
  in
    @{
      file = inp.file,
      pushback = ch :: (inp.pushback),
      line_no = inp.line_no,
      column_no = inp.column_no
    }
  end

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

exception unterminated_comment of (ullint, ullint)
exception unterminated_character_literal of (ullint, ullint)
exception multicharacter_literal of (ullint, ullint)
exception unterminated_string_literal of (ullint, ullint, bool)
exception unsupported_escape of (ullint, ullint, int)
exception invalid_integer_literal of (ullint, ullint, String)
exception unexpected_character of (ullint, ullint, int)

fn
scan_comment (inp       : inp_t,
              line_no   : ullint,
              column_no : ullint) : inp_t =
  let
    fun
    loop (inp : inp_t) : inp_t =
      let
        val (ch, inp) = get_ch inp
      in
        if (ch.ichar) < 0 then
          $raise unterminated_comment (line_no, column_no)
        else if (ch.ichar) = char2i '*' then
          let
            val (ch1, inp) = get_ch inp
          in
            if (ch.ichar) < 0 then
              $raise unterminated_comment (line_no, column_no)
            else if (ch1.ichar) = char2i '/' then
              inp
            else
              loop inp
          end
        else
          loop inp
      end
  in
    loop inp
  end

fn
skip_spaces_and_comments (inp : inp_t) : [n : pos] inp_t n =
  let
    fun
    loop (inp : inp_t) : [n : pos] inp_t n =
      let
        val (ch, inp) = get_ch inp
      in
        if isspace (ch.ichar) then
          loop inp
        else if (ch.ichar) = char2i '/' then
          let
            val (ch1, inp) = get_ch inp
          in
            if (ch1.ichar) = char2i '*' then
              loop (scan_comment (inp, ch.line_no, ch.column_no))
            else
              let
                val inp = push_back_ch (ch1, inp)
                val inp = push_back_ch (ch, inp)
              in
                inp
              end
          end
        else
          push_back_ch (ch, inp)
      end
  in
    loop inp
  end

fn
reverse_list_to_string
          {m   : int}
          (lst : list (char, m)) : string m =
  let
    fun
    fill_array {n : nat | n <= m} .<n>.
               (arr : &(@[char][m + 1]),
                lst : list (char, n),
                n   : size_t n) : void =
      case+ lst of
      | NIL => ()
      | c :: tail =>
        begin
          arr[pred n] := c;
          fill_array (arr, tail, pred n)
        end

    prval _ = lemma_list_param lst
    val m : size_t m = i2sz (list_length lst)
    val (pf, pfgc | p) = array_ptr_alloc<char> (succ m)
    val _ = array_initize_elt<char> (!p, succ m, '\0')
    val _ = fill_array (!p, lst, m)
  in
    $UN.castvwtp0 @(pf, pfgc | p)
  end

extern fun {}
simple_scan$pred : int -> bool
fun {}
simple_scan {u : nat}
            (lst : list (char, u),
             inp : inp_t) :
    [m : nat]
    [n : pos]
    (list (char, m), inp_t n) =
  let
    val (ch, inp) = get_ch inp
  in
    if simple_scan$pred (ch.ichar) then
      simple_scan<> (int2char0 (ch.ichar) :: lst, inp)
    else
      let
        val inp = push_back_ch (ch, inp)
      in
        (lst, inp)
      end
  end

fn
is_ident_start (c : int) :<> bool =
  isalpha (c) || c = char2i '_'

fn
is_ident_continuation (c : int) :<> bool =
  isalnum (c) || c = char2i '_'

fn
scan_identifier_or_reserved_word
          (inp     : inp_t,
           lookups : !lookups_vt) :
    (tokentuple_t, [n : pos] inp_t n) =
  let
    val (ch, inp) = get_ch inp
    val _ = assertloc (is_ident_start (ch.ichar))

    implement simple_scan$pred<> c = is_ident_continuation c
    val (lst, inp) = simple_scan (int2char0 (ch.ichar) :: NIL, inp)

    val s = reverse_list_to_string lst
    val toktup =
      reserved_word_lookup (s, lookups, ch.line_no, ch.column_no)
  in
    (toktup, inp)
  end

fn
scan_integer_literal
          (inp     : inp_t,
           lookups : !lookups_vt) :
    (tokentuple_t, [n : pos] inp_t n) =
  let
    val (ch, inp) = get_ch inp
    val _ = assertloc (isdigit (ch.ichar))

    implement simple_scan$pred<> c = is_ident_continuation c
    val (lst, inp) = simple_scan (int2char0 (ch.ichar) :: NIL, inp)

    val s = reverse_list_to_string lst

    fun
    check_they_are_all_digits
              {n : nat} .<n>.
              (lst : list (char, n)) : void =
      case+ lst of
      | NIL => ()
      | c :: tail =>
        if isdigit c then
          check_they_are_all_digits tail
        else
          $raise invalid_integer_literal (ch.line_no, ch.column_no, s)

    val _ = check_they_are_all_digits lst
  in
    ((TOKEN_INTEGER, s, ch.line_no, ch.column_no), inp)
  end

fn
ichar2integer_literal (c : int) : String0 =
  let
    var buf = @[char][100] ('\0')
    val _ = $extfcall (int, "snprintf", [email protected] buf, i2sz 99, "%d", c)
    val s = string1_copy ($UN.castvwtp0{String0} buf)
  in
    strnptr2string s
  end

fn
scan_character_literal_without_checking_end (inp : inp_t) :
    (tokentuple_t, inp_t) =
  let
    val (ch, inp) = get_ch inp
    val _ = assertloc ((ch.ichar) = '\'')

    val (ch1, inp) = get_ch inp
  in
    if (ch1.ichar) < 0 then
      $raise unterminated_character_literal (ch.line_no, ch.column_no)
    else if (ch1.ichar) = char2i '\\' then
      let
        val (ch2, inp) = get_ch inp
      in
        if (ch2.ichar) < 0 then
          $raise unterminated_character_literal (ch.line_no,
                                                 ch.column_no)
        else if (ch2.ichar) = char2i 'n' then
          let
            val s = ichar2integer_literal (char2i '\n')
          in
            ((TOKEN_INTEGER, s, ch.line_no, ch.column_no), inp)
          end
        else if (ch2.ichar) = char2i '\\' then
          let
            val s = ichar2integer_literal (char2i '\\')
          in
            ((TOKEN_INTEGER, s, ch.line_no, ch.column_no), inp)
          end
        else
          $raise unsupported_escape (ch1.line_no, ch1.column_no,
                                     ch2.ichar)
      end
    else
      let
        val s = ichar2integer_literal (ch1.ichar)
      in
        ((TOKEN_INTEGER, s, ch.line_no, ch.column_no), inp)
      end
  end

fn
scan_character_literal (inp : inp_t) : (tokentuple_t, inp_t) =
  let
    val (tok, inp) =
      scan_character_literal_without_checking_end inp
    val line_no = (tok.2)
    val column_no = (tok.3)

    fun
    check_end (inp : inp_t) : inp_t =
      let
        val (ch, inp) = get_ch inp
      in
        if (ch.ichar) = char2i '\'' then
          inp
        else
          let
            fun
            loop_to_end (ch1 : ch_t,
                         inp : inp_t) : inp_t =
              if (ch1.ichar) < 0 then
                $raise unterminated_character_literal (line_no,
                                                       column_no)
              else if (ch1.ichar) = char2i '\'' then
                $raise multicharacter_literal (line_no, column_no)
              else
                let
                  val (ch1, inp) = get_ch inp
                in
                  loop_to_end (ch1, inp)
                end

            val inp = loop_to_end (ch, inp)
          in
            inp
          end
      end

    val inp = check_end inp
  in
    (tok, inp)
  end

fn
scan_string_literal (inp : inp_t) : (tokentuple_t, inp_t) =
  let
    val (ch, inp) = get_ch inp
    val _ = assertloc ((ch.ichar) = '"')

    fun
    scan {u : pos}
         (lst : list (char, u),
          inp : inp_t) :
        [m : pos] (list (char, m), inp_t) =
      let
        val (ch1, inp) = get_ch inp
      in
        if (ch1.ichar) < 0 then
          $raise unterminated_string_literal (ch.line_no,
                                              ch.column_no, false)
        else if (ch1.ichar) = char2i '\n' then
          $raise unterminated_string_literal (ch.line_no,
                                              ch.column_no, true)
        else if (ch1.ichar) = char2i '"' then
          (lst, inp)
        else if (ch1.ichar) <> char2i '\\' then
          scan (int2char0 (ch1.ichar) :: lst, inp)
        else
          let
            val (ch2, inp) = get_ch inp
          in
            if (ch2.ichar) = char2i 'n' then
              scan ('n' :: '\\' :: lst, inp)
            else if (ch2.ichar) = char2i '\\' then
              scan ('\\' :: '\\' :: lst, inp)
            else
              $raise unsupported_escape (ch1.line_no, ch1.column_no,
                                         ch2.ichar)
          end
      end

    val lst = '"' :: NIL
    val (lst, inp) = scan (lst, inp)
    val lst = '"' :: lst
    val s = reverse_list_to_string lst
  in
    ((TOKEN_STRING, s, ch.line_no, ch.column_no), inp)
  end

fn
get_next_token (inp     : inp_t,
                lookups : !lookups_vt) : (tokentuple_t, inp_t) =
  let
    val inp = skip_spaces_and_comments inp
    val (ch, inp) = get_ch inp
    val ln = ch.line_no
    val cn = ch.column_no
  in
    if ch.ichar < 0 then
      ((TOKEN_END_OF_INPUT, "", ln, cn), inp)
    else
      case+ int2char0 (ch.ichar) of
      | ',' => ((TOKEN_COMMA, ",", ln, cn), inp)
      | ';' => ((TOKEN_SEMICOLON, ";", ln, cn), inp)
      | '\(' => ((TOKEN_LEFTPAREN, "(", ln, cn), inp)
      | ')' => ((TOKEN_RIGHTPAREN, ")", ln, cn), inp)
      | '\{' => ((TOKEN_LEFTBRACE, "{", ln, cn), inp)
      | '}' => ((TOKEN_RIGHTBRACE, "}", ln, cn), inp)
      | '*' => ((TOKEN_MULTIPLY, "*", ln, cn), inp)
      | '/' => ((TOKEN_DIVIDE, "/", ln, cn), inp)
      | '%' => ((TOKEN_MOD, "%", ln, cn), inp)
      | '+' => ((TOKEN_ADD, "+", ln, cn), inp)
      | '-' => ((TOKEN_SUBTRACT, "-", ln, cn), inp)
      | '<' =>
        let
          val (ch1, inp) = get_ch inp
        in
          if (ch1.ichar) = char2i '=' then
            ((TOKEN_LESSEQUAL, "<=", ln, cn), inp)
          else
            let
              val inp = push_back_ch (ch1, inp)
            in
              ((TOKEN_LESS, "<", ln, cn), inp)
            end
        end
      | '>' =>
        let
          val (ch1, inp) = get_ch inp
        in
          if (ch1.ichar) = char2i '=' then
            ((TOKEN_GREATEREQUAL, ">=", ln, cn), inp)
          else
            let
              val inp = push_back_ch (ch1, inp)
            in
              ((TOKEN_GREATER, ">", ln, cn), inp)
            end
        end
      | '=' =>
        let
          val (ch1, inp) = get_ch inp
        in
          if (ch1.ichar) = char2i '=' then
            ((TOKEN_EQUAL, "==", ln, cn), inp)
          else
            let
              val inp = push_back_ch (ch1, inp)
            in
              ((TOKEN_ASSIGN, "=", ln, cn), inp)
            end
        end
      | '!' =>
        let
          val (ch1, inp) = get_ch inp
        in
          if (ch1.ichar) = char2i '=' then
            ((TOKEN_NOTEQUAL, "!=", ln, cn), inp)
          else
            let
              val inp = push_back_ch (ch1, inp)
            in
              ((TOKEN_NOT, "!", ln, cn), inp)
            end
        end
      | '&' =>
        let
          val (ch1, inp) = get_ch inp
        in
          if (ch1.ichar) = char2i '&' then
            ((TOKEN_AND, "&&", ln, cn), inp)
          else
            $raise unexpected_character (ch.line_no, ch.column_no,
                                         ch.ichar)
        end
      | '|' =>
        let
          val (ch1, inp) = get_ch inp
        in
          if (ch1.ichar) = char2i '|' then
            ((TOKEN_OR, "||", ln, cn), inp)
          else
            $raise unexpected_character (ch.line_no, ch.column_no,
                                         ch.ichar)
        end
      | '"' =>
        let
          val inp = push_back_ch (ch, inp)
        in
          scan_string_literal inp
        end
      | '\'' =>
        let
          val inp = push_back_ch (ch, inp)
        in
          scan_character_literal inp
        end
      | _ when isdigit (ch.ichar) =>
        let
          val inp = push_back_ch (ch, inp)
        in
          scan_integer_literal (inp, lookups)
        end
      | _ when is_ident_start (ch.ichar) =>
        let
          val inp = push_back_ch (ch, inp)
        in
          scan_identifier_or_reserved_word (inp, lookups)
        end
      | _ => $raise unexpected_character (ch.line_no, ch.column_no,
                                          ch.ichar)
  end

fn
fprint_ullint_rightjust (outf : FILEref,
                         num  : ullint) : void =
  if num < 10ULL then
    fprint! (outf, "    ", num)
  else if num < 100ULL then
    fprint! (outf, "   ", num)
  else if num < 1000ULL then
    fprint! (outf, "  ", num)
  else if num < 10000ULL then
    fprint! (outf, " ", num)
  else
    fprint! (outf, num)

fn
print_token (outf    : FILEref,
             toktup  : tokentuple_t,
             lookups : !lookups_vt) : void =
  let
    macdef toknames = !(lookups.toknames)
    val name = toknames[toktup.0]
    val str = (toktup.1)
    val line_no = (toktup.2)
    val column_no = (toktup.3)

    val _ = fprint_ullint_rightjust (outf, line_no)
    val _ = fileref_puts (outf, " ")
    val _ = fprint_ullint_rightjust (outf, column_no)
    val _ = fileref_puts (outf, "  ")
    val _ = fileref_puts (outf, name)
  in
    begin
      case+ toktup.0 of
      | TOKEN_IDENTIFIER => fprint! (outf, "     ", str)
      | TOKEN_INTEGER => fprint! (outf, "        ", str)
      | TOKEN_STRING => fprint! (outf, "         ", str)
      | _ => ()
    end;

    fileref_putc (outf, '\n')
  end

fn
scan_text (outf    : FILEref,
           inp     : inp_t,
           lookups : !lookups_vt) : void =
  let
    fun
    loop (inp     : inp_t,
          lookups : !lookups_vt) : void =
      let
        val (toktup, inp) = get_next_token (inp, lookups)
      in
        print_token (outf, toktup, lookups);
        if toktup.0 <> TOKEN_END_OF_INPUT then
          loop (inp, lookups)
      end
  in
    loop (inp, lookups)
  end

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

fn
main_program (inpf : FILEref,
              outf : FILEref) : int =
  let
    (* Using a simple Scheme program, I found the following perfect
       hash for the reserved words, using the sum of the first two
       characters as the hash value. *)
    var reserved_words =
      @[String][RESERVED_WORD_HASHTAB_SIZE]
        ("if", "print", "else", "", "putc", "", "", "while", "")
    var reserved_word_tokens =
      @[token_t][RESERVED_WORD_HASHTAB_SIZE]
        (TOKEN_IF, TOKEN_PRINT, TOKEN_ELSE, TOKEN_IDENTIFIER,
         TOKEN_PUTC, TOKEN_IDENTIFIER, TOKEN_IDENTIFIER, TOKEN_WHILE,
         TOKEN_IDENTIFIER)

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

    var lookups : lookups_vt =
      @{
        pf_toknames = [email protected] token_names,
        pf_wordtab = [email protected] reserved_words,
        pf_toktab = [email protected] reserved_word_tokens |
        toknames = [email protected] token_names,
        wordtab = [email protected] reserved_words,
        toktab = [email protected] reserved_word_tokens
      }

    val inp =
      @{
        file = inpf,
        pushback = NIL,
        line_no = 1ULL,
        column_no = 1ULL
      }

    val _ = scan_text (outf, inp, lookups)

    val @{
          pf_toknames = pf_toknames,
          pf_wordtab = pf_wordtab,
          pf_toktab = pf_toktab |
          toknames = toknames,
          wordtab = wordtab,
          toktab = toktab
        } = lookups
    prval _ = [email protected] token_names := pf_toknames
    prval _ = [email protected] reserved_words := pf_wordtab
    prval _ = [email protected] reserved_word_tokens := pf_toktab
  in
    0
  end

macdef lex_error = "Lexical error: "

implement
main (argc, argv) =
  let
    val inpfname =
      if 2 <= argc then
        $UN.cast{string} argv[1]
      else
        "-"
    val outfname =
      if 3 <= argc then
        $UN.cast{string} argv[2]
      else
        "-"
  in
    try
      let
        val inpf =
          if (inpfname : string) = "-" then
            stdin_ref
          else
            fileref_open_exn (inpfname, file_mode_r)

        val outf =
          if (outfname : string) = "-" then
            stdout_ref
          else
            fileref_open_exn (outfname, file_mode_w)
      in
        main_program (inpf, outf)
      end
    with
    | ~ unterminated_comment (line_no, column_no) =>
      begin
        fprintln! (stderr_ref, lex_error,
                   "unterminated comment starting at ",
                   line_no, ":", column_no);
        1
      end
    | ~ unterminated_character_literal (line_no, column_no) =>
      begin
        fprintln! (stderr_ref, lex_error,
                   "unterminated character literal starting at ",
                   line_no, ":", column_no);
        1
      end
    | ~ multicharacter_literal (line_no, column_no) =>
      begin
        fprintln! (stderr_ref, lex_error,
                   "unsupported multicharacter literal starting at ",
                   line_no, ":", column_no);
        1
      end
    | ~ unterminated_string_literal (line_no, column_no,
                                     end_of_line) =>
      let
        val s =
          begin
            if end_of_line then
              "end of line"
            else
              "end of input"
          end : String
      in
        fprintln! (stderr_ref, lex_error,
                   "unterminated string literal (", s,
                   ") starting at ", line_no, ":", column_no);
        1
      end
    | ~ unsupported_escape (line_no, column_no, c) =>
      begin
        fprintln! (stderr_ref, lex_error,
                   "unsupported escape \\",
                   int2char0 c, " starting at ",
                   line_no, ":", column_no);
        1
      end
    | ~ invalid_integer_literal (line_no, column_no, s) =>
      begin
        fprintln! (stderr_ref, lex_error,
                   "invalid integer literal ", s,
                   " starting at ", line_no, ":", column_no);
        1
      end
    | ~ unexpected_character (line_no, column_no, c) =>
      begin
        fprintln! (stderr_ref, lex_error,
                   "unexpected character '", int2char0 c,
                   "' at ", line_no, ":", column_no);
        1
      end
end

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


BEGIN {
  all_syms["tk_EOI"    ] = "End_of_input"
  all_syms["tk_Mul"    ] = "Op_multiply"
  all_syms["tk_Div"    ] = "Op_divide"
  all_syms["tk_Mod"    ] = "Op_mod"
  all_syms["tk_Add"    ] = "Op_add"
  all_syms["tk_Sub"    ] = "Op_subtract"
  all_syms["tk_Negate" ] = "Op_negate"
  all_syms["tk_Not"    ] = "Op_not"
  all_syms["tk_Lss"    ] = "Op_less"
  all_syms["tk_Leq"    ] = "Op_lessequal"
  all_syms["tk_Gtr"    ] = "Op_greater"
  all_syms["tk_Geq"    ] = "Op_greaterequal"
  all_syms["tk_Eq"     ] = "Op_equal"
  all_syms["tk_Neq"    ] = "Op_notequal"
  all_syms["tk_Assign" ] = "Op_assign"
  all_syms["tk_And"    ] = "Op_and"
  all_syms["tk_Or"     ] = "Op_or"
  all_syms["tk_If"     ] = "Keyword_if"
  all_syms["tk_Else"   ] = "Keyword_else"
  all_syms["tk_While"  ] = "Keyword_while"
  all_syms["tk_Print"  ] = "Keyword_print"
  all_syms["tk_Putc"   ] = "Keyword_putc"
  all_syms["tk_Lparen" ] = "LeftParen"
  all_syms["tk_Rparen" ] = "RightParen"
  all_syms["tk_Lbrace" ] = "LeftBrace"
  all_syms["tk_Rbrace" ] = "RightBrace"
  all_syms["tk_Semi"   ] = "Semicolon"
  all_syms["tk_Comma"  ] = "Comma"
  all_syms["tk_Ident"  ] = "Identifier"
  all_syms["tk_Integer"] = "Integer"
  all_syms["tk_String" ] = "String"

  ## single character only symbols
  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"

  key_words["if"   ] = "tk_If"
  key_words["else" ] = "tk_Else"
  key_words["print"] = "tk_Print"
  key_words["putc" ] = "tk_Putc"
  key_words["while"] = "tk_While"

  # Set up an array that emulates the ord() function.
  for(n=0;n<256;n++)
    ord[sprintf("%c",n)]=n

  input_file = "-"
  if (ARGC > 1)
    input_file = ARGV[1]
  RS=FS=""   # read complete file into one line $0
  getline < input_file
  the_ch = " " # dummy first char - but it must be a space
  the_col  = 0 # always points to the current character
  the_line = 1
  for (the_nf=1; ; ) {
    split(gettok(), t, SUBSEP)
    printf("%5s  %5s %-14s", t[2], t[3], all_syms[t[1]])
    if      (t[1] == "tk_Integer") printf("   %5s\n", t[4])
    else if (t[1] == "tk_Ident"  ) printf("  %s\n",   t[4])
    else if (t[1] == "tk_String" ) printf("  \"%s\"\n", t[4])
    else                           print("")
    if (t[1] == "tk_EOI")
      break
  }
}

#*** show error and exit
function error(line, col, msg) {
  print(line, col, msg)
  exit(1)
}

# get the next character from the input
function next_ch() {
  the_ch = $the_nf
  the_nf  ++
  the_col ++
  if (the_ch == "\n") {
    the_line ++
    the_col = 0
  }
  return the_ch
}

#*** 'x' - character constants
function char_lit(err_line, err_col) {
  n = ord[next_ch()]              # skip opening quote
  if (the_ch == "'") {
    error(err_line, err_col, "empty character constant")
  } else if (the_ch == "\\") {
    next_ch()
    if (the_ch == "n")
      n = 10
    else if (the_ch == "\\")
      n = ord["\\"]
    else
      error(err_line, err_col, "unknown escape sequence " the_ch)
  }
  if (next_ch() != "'")
    error(err_line, err_col, "multi-character constant")
  next_ch()
  return "tk_Integer" SUBSEP err_line SUBSEP err_col SUBSEP n
}

#*** process divide or comments
function div_or_cmt(err_line, err_col) {
  if (next_ch() != "*")
    return "tk_Div" SUBSEP err_line SUBSEP err_col
  # comment found
  next_ch()
  while (1) {
    if (the_ch == "*") {
      if (next_ch() == "/") {
        next_ch()
        return gettok()
      } else if (the_ch == "") {
        error(err_line, err_col, "EOF in comment")
      }
    } else {
      next_ch()
    }
  }
}

#*** "string"
function string_lit(start, err_line, err_col) {
  text = ""
  while (next_ch() != start) {
    if (the_ch == "")
      error(err_line, err_col, "EOF while scanning string literal")
    if (the_ch == "\n")
      error(err_line, err_col, "EOL while scanning string literal")
    text = text the_ch
  }
  next_ch()
  return "tk_String" SUBSEP err_line SUBSEP err_col SUBSEP text
}

#*** handle identifiers and integers
function ident_or_int(err_line, err_col) {
  is_number = 1
  text = ""
  while ((the_ch ~ /^[0-9a-zA-Z]+$/)  || (the_ch == "_")) {
    text = text the_ch
    if (! (the_ch ~ /^[0-9]+$/))
      is_number = 0
    next_ch()
  }
  if (text == "")
    error(err_line, err_col, "ident_or_int: unrecognized character: " the_ch)
  if (text ~ /^[0-9]/) {
    if (! is_number)
      error(err_line, err_col, "invalid number: " text)
    n = text + 0
    return "tk_Integer" SUBSEP err_line SUBSEP err_col SUBSEP n
  }
  if (text in key_words)
    return key_words[text] SUBSEP err_line SUBSEP err_col
  return "tk_Ident" SUBSEP err_line SUBSEP err_col SUBSEP text
}

#*** look ahead for '>=', etc.
function follow(expect, ifyes, ifno, err_line, err_col) {
  if (next_ch() == expect) {
    next_ch()
    return ifyes SUBSEP err_line SUBSEP err_col
  }
  if (ifno == tk_EOI)
    error(err_line, err_col, "follow: unrecognized character: " the_ch)
  return ifno SUBSEP err_line SUBSEP err_col
}

#*** return the next token type
function gettok() {
  while (the_ch == " " || the_ch == "\n" || the_ch == "\r")
    next_ch()
  err_line = the_line
  err_col  = the_col
  if      (the_ch == "" )    return "tk_EOI" SUBSEP err_line SUBSEP err_col
  else if (the_ch == "/")    return div_or_cmt(err_line, err_col)
  else if (the_ch == "'")    return char_lit(err_line, err_col)
  else if (the_ch == "<")    return follow("=", "tk_Leq", "tk_Lss",    err_line, err_col)
  else if (the_ch == ">")    return follow("=", "tk_Geq", "tk_Gtr",    err_line, err_col)
  else if (the_ch == "=")    return follow("=", "tk_Eq",  "tk_Assign", err_line, err_col)
  else if (the_ch == "!")    return follow("=", "tk_Neq", "tk_Not",    err_line, err_col)
  else if (the_ch == "&")    return follow("&", "tk_And", "tk_EOI",    err_line, err_col)
  else if (the_ch == "|")    return follow("|", "tk_Or",  "tk_EOI",    err_line, err_col)
  else if (the_ch =="\"")    return string_lit(the_ch, err_line, err_col)
  else if (the_ch in symbols) {
    sym = symbols[the_ch]
    next_ch()
    return sym SUBSEP err_line SUBSEP err_col
  } else {
    return ident_or_int(err_line, err_col)
  }
}


#include <stdlib.h>
#include <stdio.h>
#include <stdarg.h>
#include <ctype.h>
#include <string.h>
#include <errno.h>
#include <stdbool.h>
#include <limits.h>

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

#define da_dim(name, type)  type *name = NULL;          \
                            int _qy_ ## name ## _p = 0;  \
                            int _qy_ ## name ## _max = 0
#define da_rewind(name)     _qy_ ## name ## _p = 0
#define da_redim(name)      do {if (_qy_ ## name ## _p >= _qy_ ## name ## _max) \
                                name = realloc(name, (_qy_ ## name ## _max += 32) * sizeof(name[0]));} while (0)
#define da_append(name, x)  do {da_redim(name); name[_qy_ ## name ## _p++] = x;} while (0)
#define da_len(name)        _qy_ ## name ## _p

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;

typedef struct {
    TokenType tok;
    int err_ln, err_col;
    union {
        int n;                  /* value for constants */
        char *text;             /* text for idents */
    };
} tok_s;

static FILE *source_fp, *dest_fp;
static int line = 1, col = 0, the_ch = ' ';
da_dim(text, char);

tok_s gettok(void);

static void error(int err_line, int err_col, const char *fmt, ... ) {
    char buf[1000];
    va_list ap;

    va_start(ap, fmt);
    vsprintf(buf, fmt, ap);
    va_end(ap);
    printf("(%d,%d) error: %s\n", err_line, err_col, buf);
    exit(1);
}

static int next_ch(void) {     /* get next char from input */
    the_ch = getc(source_fp);
    ++col;
    if (the_ch == '\n') {
        ++line;
        col = 0;
    }
    return the_ch;
}

static tok_s char_lit(int n, int err_line, int err_col) {   /* 'x' */
    if (the_ch == '\'')
        error(err_line, err_col, "gettok: empty character constant");
    if (the_ch == '\\') {
        next_ch();
        if (the_ch == 'n')
            n = 10;
        else if (the_ch == '\\')
            n = '\\';
        else error(err_line, err_col, "gettok: unknown escape sequence \\%c", the_ch);
    }
    if (next_ch() != '\'')
        error(err_line, err_col, "multi-character constant");
    next_ch();
    return (tok_s){tk_Integer, err_line, err_col, {n}};
}

static tok_s div_or_cmt(int err_line, int err_col) { /* process divide or comments */
    if (the_ch != '*')
        return (tok_s){tk_Div, err_line, err_col, {0}};

    /* comment found */
    next_ch();
    for (;;) {
        if (the_ch == '*') {
            if (next_ch() == '/') {
                next_ch();
                return gettok();
            }
        } else if (the_ch == EOF)
            error(err_line, err_col, "EOF in comment");
        else
            next_ch();
    }
}

static tok_s string_lit(int start, int err_line, int err_col) { /* "st" */
    da_rewind(text);

    while (next_ch() != start) {
        if (the_ch == '\n') error(err_line, err_col, "EOL in string");
        if (the_ch == EOF)  error(err_line, err_col, "EOF in string");
        da_append(text, (char)the_ch);
    }
    da_append(text, '\0');

    next_ch();
    return (tok_s){tk_String, err_line, err_col, {.text=text}};
}

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 {
        const 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;
}

static tok_s ident_or_int(int err_line, int err_col) {
    int n, is_number = true;

    da_rewind(text);
    while (isalnum(the_ch) || the_ch == '_') {
        da_append(text, (char)the_ch);
        if (!isdigit(the_ch))
            is_number = false;
        next_ch();
    }
    if (da_len(text) == 0)
        error(err_line, err_col, "gettok: unrecognized character (%d) '%c'\n", the_ch, the_ch);
    da_append(text, '\0');
    if (isdigit(text[0])) {
        if (!is_number)
            error(err_line, err_col, "invalid number: %s\n", text);
        n = strtol(text, NULL, 0);
        if (n == LONG_MAX && errno == ERANGE)
            error(err_line, err_col, "Number exceeds maximum value");
        return (tok_s){tk_Integer, err_line, err_col, {n}};
    }
    return (tok_s){get_ident_type(text), err_line, err_col, {.text=text}};
}

static tok_s follow(int expect, TokenType ifyes, TokenType ifno, int err_line, int err_col) {   /* look ahead for '>=', etc. */
    if (the_ch == expect) {
        next_ch();
        return (tok_s){ifyes, err_line, err_col, {0}};
    }
    if (ifno == tk_EOI)
        error(err_line, err_col, "follow: unrecognized character '%c' (%d)\n", the_ch, the_ch);
    return (tok_s){ifno, err_line, err_col, {0}};
}

tok_s gettok(void) {            /* return the token type */
    /* skip white space */
    while (isspace(the_ch))
        next_ch();
    int err_line = line;
    int err_col  = col;
    switch (the_ch) {
        case '{':  next_ch(); return (tok_s){tk_Lbrace, err_line, err_col, {0}};
        case '}':  next_ch(); return (tok_s){tk_Rbrace, err_line, err_col, {0}};
        case '(':  next_ch(); return (tok_s){tk_Lparen, err_line, err_col, {0}};
        case ')':  next_ch(); return (tok_s){tk_Rparen, err_line, err_col, {0}};
        case '+':  next_ch(); return (tok_s){tk_Add, err_line, err_col, {0}};
        case '-':  next_ch(); return (tok_s){tk_Sub, err_line, err_col, {0}};
        case '*':  next_ch(); return (tok_s){tk_Mul, err_line, err_col, {0}};
        case '%':  next_ch(); return (tok_s){tk_Mod, err_line, err_col, {0}};
        case ';':  next_ch(); return (tok_s){tk_Semi, err_line, err_col, {0}};
        case ',':  next_ch(); return (tok_s){tk_Comma,err_line, err_col, {0}};
        case '/':  next_ch(); return div_or_cmt(err_line, err_col);
        case '\'': next_ch(); return char_lit(the_ch, err_line, err_col);
        case '<':  next_ch(); return follow('=', tk_Leq, tk_Lss,    err_line, err_col);
        case '>':  next_ch(); return follow('=', tk_Geq, tk_Gtr,    err_line, err_col);
        case '=':  next_ch(); return follow('=', tk_Eq,  tk_Assign, err_line, err_col);
        case '!':  next_ch(); return follow('=', tk_Neq, tk_Not,    err_line, err_col);
        case '&':  next_ch(); return follow('&', tk_And, tk_EOI,    err_line, err_col);
        case '|':  next_ch(); return follow('|', tk_Or,  tk_EOI,    err_line, err_col);
        case '"' : return string_lit(the_ch, err_line, err_col);
        default:   return ident_or_int(err_line, err_col);
        case EOF:  return (tok_s){tk_EOI, err_line, err_col, {0}};
    }
}

void run(void) {    /* tokenize the given input */
    tok_s tok;
    do {
        tok = gettok();
        fprintf(dest_fp, "%5d  %5d %.15s",
            tok.err_ln, tok.err_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.tok * 16]);
        if (tok.tok == tk_Integer)     fprintf(dest_fp, "  %4d",   tok.n);
        else if (tok.tok == tk_Ident)  fprintf(dest_fp, " %s",     tok.text);
        else if (tok.tok == tk_String) fprintf(dest_fp, " \"%s\"", tok.text);
        fprintf(dest_fp, "\n");
    } while (tok.tok != tk_EOI);
    if (dest_fp != stdout)
        fclose(dest_fp);
}

void init_io(FILE **fp, FILE *std, const char mode[], const char fn[]) {
    if (fn[0] == '\0')
        *fp = std;
    else if ((*fp = fopen(fn, mode)) == NULL)
        error(0, 0, "Can't open %s\n", fn);
}

int main(int argc, char *argv[]) {
    init_io(&source_fp, stdin,  "r",  argc > 1 ? argv[1] : "");
    init_io(&dest_fp,   stdout, "wb", argc > 2 ? argv[2] : "");
    run();
    return 0;
}


using System;
using System.IO;
using System.Linq;
using System.Collections.Generic;

namespace Rosetta {

    public enum TokenType {
        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, None
    }

    /// <summary>
    /// Storage class for tokens
    /// </summary>
    public class Token {
        public TokenType Type { get; set; }
        public int Line { get; set; }
        public int Position { get; set; }
        public string Value { get; set; }
        public override string ToString() {
            if (Type == TokenType.Integer || Type == TokenType.Identifier) {
                return String.Format("{0,-5}  {1,-5}   {2,-14}     {3}", Line, Position, Type.ToString(), Value);
            } else if (Type == TokenType.String) {
                return String.Format("{0,-5}  {1,-5}   {2,-14}     \"{3}\"", Line, Position, Type.ToString(), Value.Replace("\n", "\\n"));
            }
            return String.Format("{0,-5}  {1,-5}   {2,-14}", Line, Position, Type.ToString());
        }
    }

    /// <summary>
    /// C# Example of Lexical scanner for Rosetta Compiler
    /// </summary>
    public class LexicalScanner {

        // character classes
        private const string _letters = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_";
        private const string _numbers = "0123456789";
        private const string _identifier = _letters + _numbers + "_";
        private const string _whitespace = " \t\n\r";

        // mappings from string keywords to token type
        private Dictionary<string, TokenType> _keywordTokenTypeMap = new Dictionary<string, TokenType>() {
            { "if", TokenType.Keyword_if },
            { "else", TokenType.Keyword_else },
            { "while", TokenType.Keyword_while },
            { "print", TokenType.Keyword_print },
            { "putc", TokenType.Keyword_putc }
        };

        // mappings from simple operators to token type
        private Dictionary<string, TokenType> _operatorTokenTypeMap = new Dictionary<string, TokenType>() {
            { "+", TokenType.Op_add },
            { "-", TokenType.Op_subtract },
            { "*", TokenType.Op_multiply },
            { "/", TokenType.Op_divide },
            { "%", TokenType.Op_mod },
            { "=", TokenType.Op_assign },
            { "<", TokenType.Op_less },
            { ">", TokenType.Op_greater },
            { "!", TokenType.Op_not },
        };

        private List<string> _keywords;
        private string _operators = "+-*/%=<>!%";

        private string _code;
        private List<Token> tokens = new List<Token>();

        private int _line = 1;
        private int _position = 1;

        public string CurrentCharacter {
            get {
                try {
                    return _code.Substring(0, 1);
                } catch (ArgumentOutOfRangeException) {
                    return "";
                }
            }
        }

        /// <summary>
        /// Lexical scanner initialiser
        /// </summary>
        /// <param name="code">Code to be tokenised</param>
        public LexicalScanner (string code) {
            _code = code;
            _keywords = _keywordTokenTypeMap.Keys.ToList();
        }

        /// <summary>
        /// Advance the cursor forward given number of characters
        /// </summary>
        /// <param name="characters">Number of characters to advance</param>
        private void advance(int characters=1) {
            try {
                // reset position when there is a newline
                if (CurrentCharacter == "\n") {
                    _position = 0;
                    _line++;
                }

                _code = _code.Substring(characters, _code.Length - characters);
                _position += characters;
            } catch (ArgumentOutOfRangeException) {
                _code = "";
            }
        }

        /// <summary>
        /// Outputs error message to the console and exits
        /// </summary>
        /// <param name="message">Error message to display to user</param>
        /// <param name="line">Line error occurred on</param>
        /// <param name="position">Line column that the error occurred at</param>
        public void error(string message, int line, int position) {
            // output error to the console and exit
            Console.WriteLine(String.Format("{0} @ {1}:{2}", message, line, position));
            Environment.Exit(1);
        }

        /// <summary>
        /// Pattern matching using first & follow matching
        /// </summary>
        /// <param name="recogniseClass">String of characters that identifies the token type
        /// or the exact match the be made if exact:true</param>
        /// <param name="matchClass">String of characters to match against remaining target characters</param>
        /// <param name="tokenType">Type of token the match represents.</param>
        /// <param name="notNextClass">Optional class of characters that cannot follow the match</param>
        /// <param name="maxLen">Optional maximum length of token value</param>
        /// <param name="exact">Denotes whether recogniseClass represents an exact match or class match.
        /// Default: false</param>
        /// <param name="discard">Denotes whether the token is kept or discarded. Default: false</param>
        /// <param name="offset">Optiona line position offset to account for discarded tokens</param>
        /// <returns>Boolean indicating if a match was made </returns>
        public bool match(string recogniseClass, string matchClass, TokenType tokenType,
                          string notNextClass=null, int maxLen=Int32.MaxValue, bool exact=false,
                          bool discard=false, int offset=0) {

            // if we've hit the end of the file, there's no more matching to be done
            if (CurrentCharacter == "")
                return false;

            // store _current_ line and position so that our vectors point at the start
            // of each token
            int line = _line;
            int position = _position;

            // special case exact tokens to avoid needing to worry about backtracking
            if (exact) {
                if (_code.StartsWith(recogniseClass)) {
                    if (!discard)
                        tokens.Add(new Token() { Type = tokenType, Value = recogniseClass, Line = line, Position = position - offset});
                    advance(recogniseClass.Length);
                    return true;
                }
                return false;
            }

            // first match - denotes the token type usually
            if (!recogniseClass.Contains(CurrentCharacter))
                return false;

            string tokenValue = CurrentCharacter;
            advance();

            // follow match while we haven't exceeded maxLen and there are still characters
            // in the code stream
            while ((matchClass ?? "").Contains(CurrentCharacter) && tokenValue.Length <= maxLen && CurrentCharacter != "") {
                tokenValue += CurrentCharacter;
                advance();
            }

            // ensure that any incompatible characters are not next to the token
            // eg 42fred is invalid, and neither recognized as a number nor an identifier.
            // _letters would be the notNextClass
            if (notNextClass != null && notNextClass.Contains(CurrentCharacter))
                error("Unrecognised character: " + CurrentCharacter, _line, _position);

            // only add tokens to the stack that aren't marked as discard - dont want
            // things like open and close quotes/comments
            if (!discard) {
                Token token = new Token() { Type = tokenType, Value = tokenValue, Line = line, Position = position - offset };
                tokens.Add(token);
            }

            return true;
        }

        /// <summary>
        /// Tokenise the input code
        /// </summary>
        /// <returns>List of Tokens</returns>
        public List<Token> scan() {

            while (CurrentCharacter != "") {
                // match whitespace
                match(_whitespace, _whitespace, TokenType.None, discard: true);

                // match integers
                match(_numbers, _numbers, TokenType.Integer, notNextClass:_letters);

                // match identifiers and keywords
                if (match(_letters, _identifier, TokenType.Identifier)) {
                    Token match = tokens.Last();
                    if (_keywords.Contains(match.Value))
                        match.Type = _keywordTokenTypeMap[match.Value];
                }

                // match string similarly to comments without allowing newlines
                // this token doesn't get discarded though
                if (match("\"", null, TokenType.String, discard:true)) {
                    string value = "";
                    int position = _position;
                    while (!match("\"", null, TokenType.String, discard:true)) {
                        // not allowed newlines in strings
                        if (CurrentCharacter == "\n")
                            error("End-of-line while scanning string literal. Closing string character not found before end-of-line", _line, _position);
                        // end of file reached before finding end of string
                        if (CurrentCharacter == "")
                            error("End-of-file while scanning string literal. Closing string character not found", _line, _position);

                        value += CurrentCharacter;

                        // deal with escape sequences - we only accept newline (\n)
                        if (value.Length >= 2) {
                            string lastCharacters = value.Substring(value.Length - 2, 2);
                            if (lastCharacters[0] == '\\') {
                                if (lastCharacters[1] != 'n') {
                                    error("Unknown escape sequence. ", _line, position);
                                }
                                value = value.Substring(0, value.Length - 2).ToString() + "\n";
                            }
                        }

                        advance();
                    }
                    tokens.Add(new Token() { Type = TokenType.String, Value = value, Line = _line, Position = position - 1});
                }

                // match string literals
                if (match("'", null, TokenType.Integer, discard:true)) {
                    int value;
                    int position = _position;
                    value = CurrentCharacter.ToCharArray()[0];
                    advance();

                    // deal with empty literals ''
                    if (value == '\'')
                        error("Empty character literal", _line, _position);

                    // deal with escaped characters, only need to worry about \n and \\
                    // throw werror on any other
                    if (value == '\\') {
                        if (CurrentCharacter == "n") {
                            value = '\n';
                        } else if (CurrentCharacter == "\\") {
                            value = '\\';
                        } else {
                            error("Unknown escape sequence. ", _line, _position - 1);
                        }
                        advance();
                    }

                    // if we haven't hit a closing ' here, there are two many characters
                    // in the literal
                    if (!match("'", null, TokenType.Integer, discard: true))
                        error("Multi-character constant", _line, _position);

                    tokens.Add(new Rosetta.Token() { Type = TokenType.Integer, Value = value.ToString(), Line = _line, Position = position - 1 });
                }

                // match comments by checking for starting token, then advancing
                // until closing token is matched
                if (match("/*", null, TokenType.None, exact: true, discard: true)) {
                    while (!match("*/", null, TokenType.None, exact: true, discard: true)) {
                        // reached the end of the file without closing comment!
                        if (CurrentCharacter == "")
                            error("End-of-file in comment. Closing comment characters not found.", _line, _position);
                        advance();
                    }
                    continue;
                }

                // match complex operators
                match("<=", null, TokenType.Op_lessequal, exact: true);
                match(">=", null, TokenType.Op_greaterequal, exact: true);
                match("==", null, TokenType.Op_equal, exact: true);
                match("!=", null, TokenType.Op_notequal, exact: true);
                match("&&", null, TokenType.Op_and, exact: true);
                match("||", null, TokenType.Op_or, exact: true);

                // match simple operators
                if (match(_operators, null, TokenType.None, maxLen:1)) {
                    Token match = tokens.Last();
                    match.Type = _operatorTokenTypeMap[match.Value];
                }

                // brackets, braces and separators
                match("(", null, TokenType.LeftParen, exact: true);
                match(")", null, TokenType.RightParen, exact: true);
                match("{", null, TokenType.LeftBrace, exact: true);
                match("}", null, TokenType.RightBrace, exact: true);
                match(";", null, TokenType.Semicolon, exact: true);
                match(",", null, TokenType.Comma, exact: true);

            }

            // end of file token
            tokens.Add(new Rosetta.Token() { Type = TokenType.End_of_input, Line = _line, Position = _position });

            return tokens;
        }

        static void Main (string[] args) {
            StreamReader inputFile;

            // if we passed in a filename, read code from that, else
            // read code from stdin
            if (args.Length > 0) {
                string path = args[0];
                try {
                    inputFile = new StreamReader(path);
                } catch (IOException) {
                    inputFile = new StreamReader(Console.OpenStandardInput(8192));
                }
            } else {
                inputFile = new StreamReader(Console.OpenStandardInput(8192));
            }

            string code = inputFile.ReadToEnd();

            // strip windows line endings out
            code = code.Replace("\r", "");

            LexicalScanner scanner = new LexicalScanner(code);
            List<Token> tokens = scanner.scan();

            foreach(Token token in tokens) {
                Console.WriteLine(token.ToString());
            }
        }
    }
}