Definition from Wikipedia:

 Lexical analysis is the process of converting a sequence of characters (such as in a computer program or web page) into a sequence of tokens (strings with an identified "meaning"). A program that performs lexical analysis may be called a lexer, tokenizer, or scanner (though "scanner" is also used to refer to the first stage of a lexer).
Task[edit]
Create a lexical analyzer for the simple programming language specified below. The
program should read input from a file and/or stdin, and write output to a file and/or
stdout. If the language being used has a lexer module/library/class, it would be great
if two versions of the solution are provided: One without the lexer module, and one with.

Input Specification
The simple programming language to be analyzed is more or less a subset of C. It supports the following tokens:

Operators


 Name 
 Common name 
 Character sequence


 Op_multiply 
 multiply 
 *


 Op_divide 
 divide 
 /


 Op_mod 
 mod 
 %


 Op_add 
 plus 
 +


 Op_subtract 
 minus 
 -


 Op_negate 
 unary minus 
 -


 Op_less 
 less than 
 <


 Op_lessequal 
 less than or equal 
 <=


 Op_greater 
 greater than 
 >


 Op_greaterequal 
 greater than or equal 
 >=


 Op_equal 
 equal 
 ==


 Op_notequal 
 not equal 
 !=


 Op_not 
 unary not 
 !


 Op_assign 
 assignment 
 =


 Op_and 
 logical and 
 &&


 Op_or 
 logical or 
 ¦¦

 The - token should always be interpreted as Op_subtract by the lexer. Turning some Op_subtract into Op_negate will be the job of the syntax analyzer, which is not part of this task.
Symbols


 Name 
 Common name 
 Character


 LeftParen 
 left parenthesis 
 (


 RightParen 
 right parenthesis 
 )


 LeftBrace 
 left brace 
 {


 RightBrace 
 right brace 
 }


 Semicolon 
 semi-colon 
 ;


 Comma 
 comma 
 ,

Keywords


 Name 
 Character sequence


 Keyword_if 
 if


 Keyword_else 
 else


 Keyword_while 
 while


 Keyword_print 
 print


 Keyword_putc 
 putc

Identifiers and literals
These differ from the the previous tokens, in that each occurrence of them has a value associated with it.



 Name

 Common name

 Format description

 Format regex

 Value


 Identifier

 identifier

 one or more letter/number/underscore characters, but not starting with a number

 [_a-zA-Z][_a-zA-Z0-9]*

 as is


 Integer

 integer literal

 one or more digits

 [0-9]+

 as is, interpreted as a number


 Integer

 char literal

 exactly one character (anything except newline or single quote) or one of the allowed escape sequences, enclosed by single quotes

 '([^'\n]|\\n|\\\\)'

 the ASCII code point number of the character, e.g. 65 for 'A' and 10 for '\n'


 String

 string literal

 zero or more characters (anything except newline or double quote), enclosed by double quotes

 "[^"\n]*"

 the characters without the double quotes and with escape sequences converted

 For char and string literals, the \n escape sequence is supported to represent a new-line character.
 For char and string literals, to represent a backslash, use \\.
 No other special sequences are supported. This means that:
 Char literals cannot represent a single quote character (value 39).
 String literals cannot represent strings containing double quote characters.
Zero-width tokens


 Name 
 Location


 End_of_input 
 when the end of the input stream is reached

White space
 Zero or more whitespace characters, or comments enclosed in /* ... */, are allowed between any two tokens, with the exceptions noted below.
 "Longest token matching" is used to resolve conflicts (e.g., in order to match <= as a single token rather than the two tokens < and =).
 Whitespace is required between two tokens that have an alphanumeric character or underscore at the edge.
 This means: keywords, identifiers, and integer literals.
 e.g. ifprint is recognized as an identifier, instead of the keywords if and print.
 e.g. 42fred is invalid, and neither recognized as a number nor an identifier.
 Whitespace is not allowed inside of tokens (except for chars and strings where they are part of the value).
 e.g. & & is invalid, and not interpreted as the && operator.
For example, the following two program fragments are equivalent, and should produce the same token stream except for the line and column positions:

 if ( p /* meaning n is prime */ ) {
    print ( n , " " ) ;
    count = count + 1 ; /* number of primes found so far */
}
 if(p){print(n," ");count=count+1;}
Complete list of token names
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

Output Format
The program output should be a sequence of lines, each consisting of the following whitespace-separated fields:

 the line number where the token starts
 the column number where the token starts
 the token name
 the token value (only for Identifier, Integer, and String tokens)
 the number of spaces between fields is up to you. Neatly aligned is nice, but not a requirement.


This task is intended to be used as part of a pipeline, with the other compiler tasks - for example:

lex < hello.t | parse | gen | vm

Or possibly:

lex hello.t lex.out
parse lex.out parse.out
gen parse.out gen.out
vm gen.out



This implies that the output of this task (the lexical analyzer) should be suitable as input to any of the Syntax Analyzer task programs.

Diagnostics
The following error conditions should be caught:



 Error

 Example


 Empty character constant

 ''


 Unknown escape sequence.

 \r


 Multi-character constant.

 'xx'


 End-of-file in comment. Closing comment characters not found.


 End-of-file while scanning string literal. Closing string character not found.


 End-of-line while scanning string literal. Closing string character not found before end-of-line.


 Unrecognized character.

 |


 Invalid number. Starts like a number, but ends in non-numeric characters.

 123abc

Test Cases


 Input

 Output



Test Case 1:

/*
  Hello world
 */
print("Hello, World!\n");


    4      1 Keyword_print
    4      6 LeftParen
    4      7 String         "Hello, World!\n"
    4     24 RightParen
    4     25 Semicolon
    5      1 End_of_input




Test Case 2:

/*
  Show Ident and Integers
 */
phoenix_number = 142857;
print(phoenix_number, "\n");


    4      1 Identifier     phoenix_number
    4     16 Op_assign
    4     18 Integer         142857
    4     24 Semicolon
    5      1 Keyword_print
    5      6 LeftParen
    5      7 Identifier     phoenix_number
    5     21 Comma
    5     23 String         "\n"
    5     27 RightParen
    5     28 Semicolon
    6      1 End_of_input




Test Case 3:

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


    5     16   Keyword_print
    5     40   Op_subtract
    6     16   Keyword_putc
    6     40   Op_less
    7     16   Keyword_if
    7     40   Op_greater
    8     16   Keyword_else
    8     40   Op_lessequal
    9     16   Keyword_while
    9     40   Op_greaterequal
   10     16   LeftBrace
   10     40   Op_equal
   11     16   RightBrace
   11     40   Op_notequal
   12     16   LeftParen
   12     40   Op_and
   13     16   RightParen
   13     40   Op_or
   14     16   Op_subtract
   14     40   Semicolon
   15     16   Op_not
   15     40   Comma
   16     16   Op_multiply
   16     40   Op_assign
   17     16   Op_divide
   17     40   Integer             42
   18     16   Op_mod
   18     40   String          "String literal"
   19     16   Op_add
   19     40   Identifier      variable_name
   20     26   Integer             10
   21     26   Integer             92
   22     26   Integer             32
   23      1   End_of_input




Test Case 4:

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


    2      1 Keyword_print
    2      6 LeftParen
    2      7 Integer            42
    2      9 RightParen
    2     10 Semicolon
    3      1 Keyword_print
    3      6 LeftParen
    3      7 String          "\nHello World\nGood Bye\nok\n"
    3     38 RightParen
    3     39 Semicolon
    4      1 Keyword_print
    4      6 LeftParen
    4      7 String          "Print a slash n - \\n.\n"
    4     33 RightParen
    4     34 Semicolon
    5      1 End_of_input


Additional examples
Your solution should pass all the test cases above and the additional tests found Here.



Reference
The C and Python versions can be considered reference implementations.



Related Tasks
 Syntax Analyzer task
 Code Generator task
 Virtual Machine Interpreter task
 AST Interpreter task



######################################################################
#
# The Rosetta Code scanner in Ratfor 77.
#
#
# How to deal with FORTRAN 77 input is a problem. I use formatted
# input, treating each line as an array of type CHARACTER--regrettably
# of no more than some predetermined, finite length. It is a very
# simple method and presents no significant difficulties, aside from
# the restriction on line length of the input.
#
#
# On a POSIX platform, the program can be compiled with f2c and run
# somewhat as follows:
#
#    ratfor77 lex-in-ratfor.r > lex-in-ratfor.f
#    f2c -C -Nc40 lex-in-ratfor.f
#    cc -O lex-in-ratfor.c -lf2c
#    ./a.out < compiler-tests/primes.t
#
# With gfortran, a little differently:
#
#    ratfor77 lex-in-ratfor.r > lex-in-ratfor.f
#    gfortran -O2 -fcheck=all -std=legacy lex-in-ratfor.f
#    ./a.out < compiler-tests/primes.t
#
#
# I/O is strictly from default input and to default output, which, on
# POSIX systems, usually correspond respectively to standard input and
# standard output. (I did not wish to have to deal with unit numbers;
# these are now standardized in ISO_FORTRAN_ENV, but that is not
# available in FORTRAN 77.)
#
#---------------------------------------------------------------------
 
# Some parameters you may with to modify.
 
define(LINESZ, 256)           # Size of an input line.
define(OUTLSZ, 512)           # Size of an output line.
define(PSHBSZ, 10)            # Size of the character pushback buffer.
define(STRNSZ, 4096)          # Size of the string pool.
 
#---------------------------------------------------------------------
 
define(EOF, -1)
define(NEWLIN, 10)          # Unix newline (the LF control character).
define(BACKSL, 92)          # ASCII backslash.
 
define(ILINNO, 1)               # Line number's index.
define(ICOLNO, 2)               # Column number's index.
 
define(CHRSZ,  3)               # See ILINNO and ICOLNO above.
define(ICHRCD, 3)               # Character code's index.
 
define(TOKSZ,  5)               # See ILINNO and ICOLNO above.
define(ITOKNO, 3)               # Token number's index.
define(IARGIX, 4)               # Index of the string pool index.
define(IARGLN, 5)               # Index of the string length.
 
define(TKELSE,  0)
define(TKIF,    1)
define(TKPRNT,  2)
define(TKPUTC,  3)
define(TKWHIL,  4)
define(TKMUL,   5)
define(TKDIV,   6)
define(TKMOD,   7)
define(TKADD,   8)
define(TKSUB,   9)
define(TKNEG,  10)
define(TKLT,   11)
define(TKLE,   12)
define(TKGT,   13)
define(TKGE,   14)
define(TKEQ,   15)
define(TKNE,   16)
define(TKNOT,  17)
define(TKASGN, 18)
define(TKAND,  19)
define(TKOR,   20)
define(TKLPAR, 21)
define(TKRPAR, 22)
define(TKLBRC, 23)
define(TKRBRC, 24)
define(TKSEMI, 25)
define(TKCMMA, 26)
define(TKID,   27)
define(TKINT,  28)
define(TKSTR,  29)
define(TKEOI,  30)
 
define(LOC10, 1)                # Location of "10" in the string pool.
define(LOC92, 3)                # Location of "92" in the string pool.
 
#---------------------------------------------------------------------
 
subroutine addstr (strngs, istrng, src, i0, n0, i, n)
 
  # Add a string to the string pool.
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character src(*)              # Source string.
  integer i0, n0                # Index and length in source string.
  integer i, n                  # Index and length in string pool.
 
  integer j
 
  if (STRNSZ < istrng + (n0 - 1))
    {
      write (*, '(''string pool exhausted'')')
      stop
    }
  for (j = 0; j < n0; j = j + 1)
    strngs(istrng + j) = src(i0 + j)
  i = istrng
  n = n0
  istrng = istrng + n0
end
 
subroutine cpystr (strngs, i, n, dst, i0)
 
  # Copy a string from the string pool to an output string.
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer i, n                  # Index and length in string pool.
  character dst(OUTLSZ)         # Destination string.
  integer i0                    # Index within destination string.
 
  integer j
 
  if (i0 < 1 || OUTLSZ < i0 + (n - 1))
    {
      write (*, '(''string boundary exceeded'')')
      stop
    }
  for (j = 0; j < n; j = j + 1)
    dst(i0 + j) = strngs(i + j)
end
 
#---------------------------------------------------------------------
 
subroutine getchr (line, linno, colno, pushbk, npshbk, chr)
 
  # Get a character, with its line number and column number.
 
  implicit none
 
  character line(LINESZ)        # Input buffer.
  integer linno, colno          # Current line and column numbers.
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
  integer chr(CHRSZ)
 
  # End of file is indicated (as in C) by a negative "char code"
  # called "EOF".
 
  character*20 fmt
  integer stat
  integer chr1(CHRSZ)
 
  if (0 < npshbk)
    {
      chr(ICHRCD) = pushbk(ICHRCD, npshbk)
      chr(ILINNO) = pushbk(ILINNO, npshbk)
      chr(ICOLNO) = pushbk(ICOLNO, npshbk)
      npshbk =  npshbk - 1
    }
  else if (colno <= LINESZ)
    {
      chr(ICHRCD) = ichar (line(colno))
      chr(ILINNO) = linno
      chr(ICOLNO) = colno
      colno = colno + 1
    }
  else
    {
      # Return a newline character.
      chr(ICHRCD) = NEWLIN
      chr(ILINNO) = linno
      chr(ICOLNO) = colno
 
      # Fetch a new line.
      linno = linno + 1
      colno = 1
 
      # Read a line of text as an array of characters.
      write (fmt, '(''('', I10, ''A1)'')') LINESZ
      read (*, fmt, iostat = stat) line
 
      if (stat != 0)
        {
          # If end of file has been reached, push an EOF.
          chr1(ICHRCD) = EOF
          chr1(ILINNO) = linno
          chr1(ICOLNO) = colno
          call pshchr (pushbk, npshbk, chr1)
        }
    }
end
 
subroutine pshchr (pushbk, npshbk, chr)
 
  # Push back a character.
 
  implicit none
 
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
  integer chr(CHRSZ)
 
  if (PSHBSZ <= npshbk)
    {
      write (*, '(''pushback buffer overfull'')')
      stop
    }
  npshbk = npshbk + 1
  pushbk(ICHRCD, npshbk) = chr(ICHRCD)
  pushbk(ILINNO, npshbk) = chr(ILINNO)
  pushbk(ICOLNO, npshbk) = chr(ICOLNO)
end
 
subroutine getpos (line, linno, colno, pushbk, npshbk, ln, cn)
 
  # Get the position of the next character.
 
  implicit none
 
  character line(LINESZ)        # Input buffer.
  integer linno, colno          # Current line and column numbers.
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
  integer ln, cn                # The line and column nos. returned.
 
  integer chr(CHRSZ)
 
  call getchr (line, linno, colno, pushbk, npshbk, chr)
  ln = chr(ILINNO)
  cn = chr(ICOLNO)
  call pshchr (pushbk, npshbk, chr)
end
 
#---------------------------------------------------------------------
 
function isspc (c)
 
  # Is c character code for a space?
 
  implicit none
 
  integer c
  logical isspc
 
  #
  # The following is correct for ASCII: 32 is the SPACE character, and
  # 9 to 13 are control characters commonly regarded as spaces.
  #
  # In Unicode these are all code points for spaces, but so are others
  # besides.
  #
  isspc = (c == 32 || (9 <= c && c <= 13))
end
 
function isdgt (c)
 
  # Is c character code for a digit?
 
  implicit none
 
  integer c
  logical isdgt
 
  isdgt = (ichar ('0') <= c && c <= ichar ('9'))
end
 
function isalph (c)
 
  # Is c character code for a letter?
 
  implicit none
 
  integer c
  logical isalph
 
  #
  # The following is correct for ASCII and Unicode, but not for
  # EBCDIC.
  #
  isalph = (ichar ('a') <= c && c <= ichar ('z')) _
             || (ichar ('A') <= c && c <= ichar ('Z'))
end
 
function isid0 (c)
 
  # Is c character code for the start of an identifier?
 
  implicit none
 
  integer c
  logical isid0
 
  logical isalph
 
  isid0 = isalph (c) || c == ichar ('_')
end
 
function isid1 (c)
 
  # Is c character code for the continuation of an identifier?
 
  implicit none
 
  integer c
  logical isid1
 
  logical isalph
  logical isdgt
 
  isid1 = isalph (c) || isdgt (c) || c == ichar ('_')
end
 
#---------------------------------------------------------------------
 
function trimlf (str, n)
 
  # "Trim left" leading spaces.
 
  implicit none
 
  character str(*)             # The string to "trim".
  integer n                    # The length.
  integer trimlf               # The index of the first non-space
                               # character, or n + 1.
 
  logical isspc
 
  integer j
  logical done
 
  j = 1
  done = .false.
  while (!done)
    {
      if (j == n + 1)
        done = .true.
      else if (!isspc (ichar (str(j))))
        done = .true.
      else
        j = j + 1
    }
  trimlf = j
end
 
function trimrt (str, n)
 
  # "Trim right" trailing spaces.
 
  implicit none
 
  character str(*)             # The string to "trim".
  integer n                    # The length including trailing spaces.
  integer trimrt               # The length without trailing spaces.
 
  logical isspc
 
  integer j
  logical done
 
  j = n
  done = .false.
  while (!done)
    {
      if (j == 0)
        done = .true.
      else if (!isspc (ichar (str(j))))
        done = .true.
      else
        j = j - 1
    }
  trimrt = j
end
 
#---------------------------------------------------------------------
 
subroutine toknam (tokno, str, i)
 
  # Copy a token name to the character array str, starting at i.
 
  implicit none
 
  integer tokno
  character str(*)
  integer i
  integer j
 
  character*16 names(0:30)
  character*16 nm
 
  data names / "Keyword_else    ", _
               "Keyword_if      ", _
               "Keyword_print   ", _
               "Keyword_putc    ", _
               "Keyword_while   ", _
               "Op_multiply     ", _
               "Op_divide       ", _
               "Op_mod          ", _
               "Op_add          ", _
               "Op_subtract     ", _
               "Op_negate       ", _
               "Op_less         ", _
               "Op_lessequal    ", _
               "Op_greater      ", _
               "Op_greaterequal ", _
               "Op_equal        ", _
               "Op_notequal     ", _
               "Op_not          ", _
               "Op_assign       ", _
               "Op_and          ", _
               "Op_or           ", _
               "LeftParen       ", _
               "RightParen      ", _
               "LeftBrace       ", _
               "RightBrace      ", _
               "Semicolon       ", _
               "Comma           ", _
               "Identifier      ", _
               "Integer         ", _
               "String          ", _
               "End_of_input    " /
 
  nm = names(tokno)
  for (j = 0; j < 16; j = j + 1)
    str(i + j) = nm(1 + j : 1 + j)
end
 
subroutine intstr (str, i, n, x)
 
  # Convert a positive integer to a substring.
 
  implicit none
 
  character str(*)              # Destination string.
  integer i, n                  # Index and length of the field.
  integer x                     # The positive integer to represent.
 
  integer j
  integer y
 
  if (x == 0)
    {
      for (j = 0; j < n - 1; j = j + 1)
        str(i + j) = ' '
      str(i + j) = '0'
    }
  else
    {
      y = x
      for (j = n - 1; 0 <= j; j = j - 1)
        {
          if (y == 0)
            str(i + j) = ' '
          else
            {
              str(i + j) = char (mod (y, 10) + ichar ('0'))
              y = y / 10
            }
        }
    }
end
 
subroutine prttok (strngs, tok)
 
  # Print a token.
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer tok(TOKSZ)            # The token.
 
  integer trimrt
 
  character line(OUTLSZ)
  character*20 fmt
  integer i, n
  integer tokno
 
  for (i = 1; i <= OUTLSZ; i = i + 1)
    line(i) = ' '
 
  call intstr (line, 1, 10, tok(ILINNO))
  call intstr (line, 12, 10, tok(ICOLNO))
 
  tokno = tok(ITOKNO)
  call toknam (tokno, line, 25)
  if (tokno == TKID || tokno == TKINT || tokno == TKSTR)
    {
      i = tok(IARGIX)
      n = tok(IARGLN)
      call cpystr (strngs, i, n, line, 45)
    }
 
  n = trimrt (line, OUTLSZ)
  write (fmt, '(''('', I10, ''A)'')') n
  write (*, fmt) (line(i), i = 1, n)
end
 
#---------------------------------------------------------------------
 
subroutine wrtpos (ln, cn)
 
  implicit none
 
  integer ln, cn
 
  write (*, 1000) ln, cn
1000 format ('At line ', I5, ', column ' I5)
end
 
#---------------------------------------------------------------------
 
subroutine utcmnt (ln, cn)
 
  implicit none
 
  integer ln, cn
 
  call wrtpos (ln, cn)
  write (*, '(''Unterminated comment'')')
  stop
end
 
subroutine skpcmt (line, linno, colno, pushbk, npshbk, ln, cn)
 
  # Skip to the end of a comment.
 
  implicit none
 
  character line(LINESZ)        # Input buffer.
  integer linno, colno          # Current line and column numbers.
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
  integer ln, cn                # Line and column of start of comment.
 
  integer chr(CHRSZ)
  logical done
 
  done = .false.
  while (!done)
    {
      call getchr (line, linno, colno, pushbk, npshbk, chr)
      if (chr(ICHRCD) == ichar ('*'))
        {
          call getchr (line, linno, colno, pushbk, npshbk, chr)
          if (chr(ICHRCD) == ichar ('/'))
            done = .true.
          else if (chr(ICHRCD) == EOF)
            call utcmnt (ln, cn)
        }
      else if (chr(ICHRCD) == EOF)
        call utcmnt (ln, cn)
    }
end
 
subroutine skpspc (line, linno, colno, pushbk, npshbk)
 
  # Skip spaces and comments.
 
  implicit none
 
  character line(LINESZ)        # Input buffer.
  integer linno, colno          # Current line and column numbers.
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
 
  logical isspc
 
  integer chr(CHRSZ)
  integer chr1(CHRSZ)
  integer ln, cn
  logical done
 
  done = .false.
  while (!done)
    {
      call getchr (line, linno, colno, pushbk, npshbk, chr)
      if (!isspc (chr(ICHRCD)))
        {
          if (chr(ICHRCD) != ichar ('/'))
            {
              call pshchr (pushbk, npshbk, chr)
              done = .true.
            }
          else
            {
              call getchr (line, linno, colno, pushbk, npshbk, chr1)
              if (chr1(ICHRCD) != ichar ('*'))
                {
                  call pshchr (pushbk, npshbk, chr1)
                  call pshchr (pushbk, npshbk, chr)
                  done = .true.
                }
              else
                {
                  ln = chr(ILINNO)
                  cn = chr(ICOLNO)
                  call skpcmt (line, linno, colno, pushbk, npshbk, _
                               ln, cn)
                }
            }
        }
    }
end
 
#---------------------------------------------------------------------
 
subroutine rwdlkp (strngs, istrng, src, i0, n0, ln, cn, tok)
 
  # Reserved word lookup
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character src(*)              # The source string.
  integer i0, n0                # Index and length of the substring.
  integer ln, cn                # Line and column number
                                #   to associate with the token.
  integer tok(TOKSZ)            # The output token.
 
  integer tokno
  integer i, n
 
  tokno = TKID
 
  if (n0 == 2)
    {
      if (src(i0) == 'i' && src(i0 + 1) == 'f')
        tokno = TKIF
    }
  else if (n0 == 4)
    {
      if (src(i0) == 'e' && src(i0 + 1) == 'l' _
            && src(i0 + 2) == 's' && src(i0 + 3) == 'e')
        tokno = TKELSE
      else if (src(i0) == 'p' && src(i0 + 1) == 'u' _
                 && src(i0 + 2) == 't' && src(i0 + 3) == 'c')
        tokno = TKPUTC
    }
  else if (n0 == 5)
    {
      if (src(i0) == 'p' && src(i0 + 1) == 'r' _
            && src(i0 + 2) == 'i' && src(i0 + 3) == 'n' _
            && src(i0 + 4) == 't')
        tokno = TKPRNT
      else if (src(i0) == 'w' && src(i0 + 1) == 'h' _
                 && src(i0 + 2) == 'i' && src(i0 + 3) == 'l' _
                 && src(i0 + 4) == 'e')
        tokno = TKWHIL
    }
 
  i = 0
  n = 0
  if (tokno == TKID)
    call addstr (strngs, istrng, src, i0, n0, i, n)
 
  tok(ITOKNO) = tokno
  tok(IARGIX) = i
  tok(IARGLN) = n
  tok(ILINNO) = ln
  tok(ICOLNO) = cn
end
 
subroutine scnwrd (line, linno, colno, pushbk, npshbk, ln, cn, buf, n)
 
  # Scan characters that may represent an identifier, reserved word,
  # or integer literal.
 
  implicit none
 
  character line(LINESZ)        # Input buffer.
  integer linno, colno          # Current line and column numbers.
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
  integer ln, cn                # Line and column number of the start.
  character buf(LINESZ)         # The output buffer.
  integer n                     # The length of the string collected.
 
  logical isid1
 
  integer chr(CHRSZ)
 
  n = 0
  call getchr (line, linno, colno, pushbk, npshbk, chr)
  ln = chr(ILINNO)
  cn = chr(ICOLNO)
  while (isid1 (chr(ICHRCD)))
    {
      n = n + 1
      buf(n) = char (chr(ICHRCD))
      call getchr (line, linno, colno, pushbk, npshbk, chr)
    }
  call pshchr (pushbk, npshbk, chr)
end
 
subroutine scnidr (strngs, istrng, _
                   line, linno, colno, pushbk, npshbk, _
                   tok)
 
  # Scan an identifier or reserved word.
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character line(LINESZ)        # Input buffer.
  integer linno, colno          # Current line and column numbers.
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
  integer ln, cn                # Line and column number of the start.
  integer tok(TOKSZ)            # The output token.
 
  character buf(LINESZ)
  integer n
 
  call scnwrd (line, linno, colno, pushbk, npshbk, ln, cn, buf, n)
  call rwdlkp (strngs, istrng, buf, 1, n, ln, cn, tok)
end
 
subroutine scnint (strngs, istrng, _
                   line, linno, colno, pushbk, npshbk, _
                   tok)
 
  # Scan a positive integer literal.
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character line(LINESZ)        # Input buffer.
  integer linno, colno          # Current line and column numbers.
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
  integer ln, cn                # Line and column number of the start.
  integer tok(TOKSZ)            # The output token.
 
  logical isdgt
 
  character buf(LINESZ)
  integer n0, n
  integer i, j, k
  character*80 fmt
 
  call scnwrd (line, linno, colno, pushbk, npshbk, ln, cn, buf, n0)
  for (j = 1; j <= n0; j = j + 1)
    if (!isdgt (ichar (buf(j))))
      {
        call wrtpos (ln, cn)
        write (fmt, 1000) n0
1000    format ('(''Not a legal word: "''', I10, 'A, ''"'')')
        write (*, fmt) (buf(k), k = 1, n0)
        stop
      }
 
  call addstr (strngs, istrng, buf, 1, n0, i, n)
 
  tok(ITOKNO) = TKINT
  tok(IARGIX) = i
  tok(IARGLN) = n
  tok(ILINNO) = ln
  tok(ICOLNO) = cn
end
 
subroutine utclit (ln, cn)
 
  implicit none
 
  integer ln, cn
 
  call wrtpos (ln, cn)
  write (*, '(''Unterminated character literal'')')
  stop
end
 
subroutine scnch1 (strngs, istrng, _
                   line, linno, colno, pushbk, npshbk, _
                   tok)
 
  # Scan a character literal, without yet checking that the literal
  # ends correctly.
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character line(LINESZ)        # Input buffer.
  integer linno, colno          # Current line and column numbers.
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
  integer tok(TOKSZ)            # The output token.
 
  integer trimlf
 
  integer bufsz
  parameter (bufsz = 40)
 
  integer chr(CHRSZ)
  integer chr1(CHRSZ)
  integer chr2(CHRSZ)
  integer ln, cn
  character buf(bufsz)
  integer i, j, n
 
  # Refetch the opening quote.
  call getchr (line, linno, colno, pushbk, npshbk, chr)
  ln = chr(ILINNO)
  cn = chr(ICOLNO)
 
  tok(ITOKNO) = TKINT
  tok(ILINNO) = ln
  tok(ICOLNO) = cn
 
  call getchr (line, linno, colno, pushbk, npshbk, chr1)
  if (chr1(ICHRCD) == EOF)
    call utclit (ln, cn)
  if (chr1(ICHRCD) == BACKSL)
    {
      call getchr (line, linno, colno, pushbk, npshbk, chr2)
      if (chr2(ICHRCD) == EOF)
        call utclit (ln, cn)
      else if (chr2(ICHRCD) == ichar ('n'))
        {
          tok(IARGIX) = LOC10   # "10" = code for Unix newline
          tok(IARGLN) = 2
        }
      else if (chr2(ICHRCD) == BACKSL)
        {
          tok(IARGIX) = LOC92   # "92" = code for backslash
          tok(IARGLN) = 2
        }
      else
        {
          call wrtpos (ln, cn)
          write (*, '(''Unsupported escape: '', 1A)') _
                char (chr2(ICHRCD))
          stop
        }
    }
  else
    {
      # Character codes are non-negative, so we can use intstr.
      call intstr (buf, 1, bufsz, chr1(ICHRCD))
 
      j = trimlf (buf, bufsz)
      call addstr (strngs, istrng, buf, j, bufsz - (j - 1), i, n)
      tok(IARGIX) = i
      tok(IARGLN) = n
    }
end
 
subroutine scnch (strngs, istrng, _
                  line, linno, colno, pushbk, npshbk, _
                  tok)
 
  # Scan a character literal.
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character line(LINESZ)        # Input buffer.
  integer linno, colno          # Current line and column numbers.
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
  integer tok(TOKSZ)            # The output token.
 
  integer ln, cn
  integer chr(CHRSZ)
 
  call getpos (line, linno, colno, pushbk, npshbk, ln, cn)
  call scnch1 (strngs, istrng, _
               line, linno, colno, pushbk, npshbk, _
               tok)
  call getchr (line, linno, colno, pushbk, npshbk, chr)
  if (chr(ICHRCD) != ichar (''''))
    {
      while (.true.)
        {
          if (chr(ICHRCD) == EOF)
            {
              call utclit (ln, cn)
              stop
            }
          else if (chr(ICHRCD) == ichar (''''))
            {
              call wrtpos (ln, cn)
              write (*, '(''Unsupported multicharacter literal'')')
              stop
            }
          call getchr (line, linno, colno, pushbk, npshbk, chr)
        }
    }
end
 
subroutine scnstr (strngs, istrng, _
                   line, linno, colno, pushbk, npshbk, _
                   tok)
 
  # Scan a string literal.
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character line(LINESZ)        # Input buffer.
  integer linno, colno          # Current line and column numbers.
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
  integer tok(TOKSZ)            # The output token.
 
  integer ln, cn
  integer chr1(CHRSZ)
  integer chr2(CHRSZ)
  character buf(LINESZ + 10)  # Enough space, with some room to spare.
  integer n0
  integer i, n
 
  call getchr (line, linno, colno, pushbk, npshbk, chr1)
  ln = chr1(ILINNO)
  cn = chr1(ICOLNO)
 
  tok(ITOKNO) = TKSTR
  tok(ILINNO) = ln
  tok(ICOLNO) = cn
 
  n0 = 1
  buf(n0) = '"'
 
  call getchr (line, linno, colno, pushbk, npshbk, chr1)
  while (chr1(ICHRCD) != ichar ('"'))
    {
      # Our input method always puts a NEWLIN before EOF, and so this
      # test is redundant, unless someone changes the input method.
      if (chr1(ICHRCD) == EOF || chr1(ICHRCD) == NEWLIN)
        {
          call wrtpos (ln, cn)
          write (*, '(''Unterminated string literal'')')
          stop
        }
      if (chr1(ICHRCD) == BACKSL)
        {
          call getchr (line, linno, colno, pushbk, npshbk, chr2)
          if (chr2(ICHRCD) == ichar ('n'))
            {
              n0 = n0 + 1
              buf(n0) = char (BACKSL)
              n0 = n0 + 1
              buf(n0) = 'n'
            }
          else if (chr2(ICHRCD) == BACKSL)
            {
              n0 = n0 + 1
              buf(n0) = char (BACKSL)
              n0 = n0 + 1
              buf(n0) = char (BACKSL)
            }
          else
            {
              call wrtpos (chr1(ILINNO), chr1(ICOLNO))
              write (*, '(''Unsupported escape sequence'')')
              stop
            }
        }
      else
        {
          n0 = n0 + 1
          buf(n0) = char (chr1(ICHRCD))
        }
      call getchr (line, linno, colno, pushbk, npshbk, chr1)
    }
  n0 = n0 + 1
  buf(n0) = '"'
 
  call addstr (strngs, istrng, buf, 1, n0, i, n)
  tok(IARGIX) = i
  tok(IARGLN) = n
end
 
subroutine unxchr (chr)
 
  implicit none
 
  integer chr(CHRSZ)
 
  call wrtpos (chr(ILINNO), chr(ICOLNO))
  write (*, 1000) char (chr(ICHRCD))
1000 format ('Unexpected character ''', A1, '''')
  stop
end
 
subroutine scntok (strngs, istrng, _
                   line, linno, colno, pushbk, npshbk, _
                   tok)
 
  # Scan a token.
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character line(LINESZ)        # Input buffer.
  integer linno, colno          # Current line and column numbers.
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
  integer tok(TOKSZ)            # The output token.
 
  logical isdgt
  logical isid0
 
  integer chr(CHRSZ)
  integer chr1(CHRSZ)
  integer ln, cn
 
  call getchr (line, linno, colno, pushbk, npshbk, chr)
  ln = chr(ILINNO)
  cn = chr(ICOLNO)
  tok(ILINNO) = ln
  tok(ICOLNO) = cn
  tok(IARGIX) = 0
  tok(IARGLN) = 0
  if (chr(ICHRCD) == ichar (','))
    tok(ITOKNO) = TKCMMA
  else if (chr(ICHRCD) == ichar (';'))
    tok(ITOKNO) = TKSEMI
  else if (chr(ICHRCD) == ichar ('('))
    tok(ITOKNO) = TKLPAR
  else if (chr(ICHRCD) == ichar (')'))
    tok(ITOKNO) = TKRPAR
  else if (chr(ICHRCD) == ichar ('{'))
    tok(ITOKNO) = TKLBRC
  else if (chr(ICHRCD) == ichar ('}'))
    tok(ITOKNO) = TKRBRC
  else if (chr(ICHRCD) == ichar ('*'))
    tok(ITOKNO) = TKMUL
  else if (chr(ICHRCD) == ichar ('/'))
    tok(ITOKNO) = TKDIV
  else if (chr(ICHRCD) == ichar ('%'))
    tok(ITOKNO) = TKMOD
  else if (chr(ICHRCD) == ichar ('+'))
    tok(ITOKNO) = TKADD
  else if (chr(ICHRCD) == ichar ('-'))
    tok(ITOKNO) = TKSUB
  else if (chr(ICHRCD) == ichar ('<'))
    {
      call getchr (line, linno, colno, pushbk, npshbk, chr1)
      if (chr1(ICHRCD) == ichar ('='))
        tok(ITOKNO) = TKLE
      else
        {
          call pshchr (pushbk, npshbk, chr1)
          tok(ITOKNO) = TKLT
        }
    }
  else if (chr(ICHRCD) == ichar ('>'))
    {
      call getchr (line, linno, colno, pushbk, npshbk, chr1)
      if (chr1(ICHRCD) == ichar ('='))
        tok(ITOKNO) = TKGE
      else
        {
          call pshchr (pushbk, npshbk, chr1)
          tok(ITOKNO) = TKGT
        }
    }
  else if (chr(ICHRCD) == ichar ('='))
    {
      call getchr (line, linno, colno, pushbk, npshbk, chr1)
      if (chr1(ICHRCD) == ichar ('='))
        tok(ITOKNO) = TKEQ
      else
        {
          call pshchr (pushbk, npshbk, chr1)
          tok(ITOKNO) = TKASGN
        }
    }
  else if (chr(ICHRCD) == ichar ('!'))
    {
      call getchr (line, linno, colno, pushbk, npshbk, chr1)
      if (chr1(ICHRCD) == ichar ('='))
        tok(ITOKNO) = TKNE
      else
        {
          call pshchr (pushbk, npshbk, chr1)
          tok(ITOKNO) = TKNOT
        }
    }
  else if (chr(ICHRCD) == ichar ('&'))
    {
      call getchr (line, linno, colno, pushbk, npshbk, chr1)
      if (chr1(ICHRCD) == ichar ('&'))
        tok(ITOKNO) = TKAND
      else
        call unxchr (chr)
    }
  else if (chr(ICHRCD) == ichar ('|'))
    {
      call getchr (line, linno, colno, pushbk, npshbk, chr1)
      if (chr1(ICHRCD) == ichar ('|'))
        tok(ITOKNO) = TKOR
      else
        call unxchr (chr)
    }
  else if (chr(ICHRCD) == ichar ('"'))
    {
      call pshchr (pushbk, npshbk, chr)
      call scnstr (strngs, istrng, _
                   line, linno, colno, pushbk, npshbk, _
                   tok)
    }
  else if (chr(ICHRCD) == ichar (''''))
    {
      call pshchr (pushbk, npshbk, chr)
      call scnch (strngs, istrng, _
                  line, linno, colno, pushbk, npshbk, _
                  tok)
    }
  else if (isdgt (chr(ICHRCD)))
    {
      call pshchr (pushbk, npshbk, chr)
      call scnint (strngs, istrng, _
                   line, linno, colno, pushbk, npshbk, _
                   tok)
    }
  else if (isid0 (chr(ICHRCD)))
    {
      call pshchr (pushbk, npshbk, chr)
      call scnidr (strngs, istrng, _
                   line, linno, colno, pushbk, npshbk, _
                   tok)
    }
  else
    call unxchr (chr)
end
 
subroutine scntxt (strngs, istrng, _
                   line, linno, colno, pushbk, npshbk)
 
  # Scan the text and print the token stream.
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character line(LINESZ)        # Input buffer.
  integer linno, colno          # Current line and column numbers.
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
 
  integer chr(CHRSZ)
  integer tok(TOKSZ)
 
  chr(ICHRCD) = ichar ('x')
  while (chr(ICHRCD) != EOF)
    {
      call skpspc (line, linno, colno, pushbk, npshbk)
      call getchr (line, linno, colno, pushbk, npshbk, chr)
      if (chr(ICHRCD) != EOF)
        {
          call pshchr (pushbk, npshbk, chr)
          call scntok (strngs, istrng, _
                       line, linno, colno, pushbk, npshbk, _
                       tok)
          call prttok (strngs, tok)
        }
    }
  tok(ITOKNO) = TKEOI
  tok(ILINNO) = chr(ILINNO)
  tok(ICOLNO) = chr(ICOLNO)
  tok(IARGIX) = 0
  tok(IARGLN) = 0
  call prttok (strngs, tok)
end
 
#---------------------------------------------------------------------
 
program lex
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character line(LINESZ)        # Input buffer.
  integer linno, colno          # Current line and column numbers.
  integer pushbk(CHRSZ, PSHBSZ) # Pushback buffer.
  integer npshbk                # Number of characters pushed back.
 
  integer i, n
 
  istrng = 1
 
  # Locate "10" (newline) at 1 in the string pool.
  line(1) = '1'
  line(2) = '0'
  call addstr (strngs, istrng, line, 1, 2, i, n)
  if (i != 1 && n != 2)
    {
      write (*, '(''internal error'')')
      stop
    }
 
  # Locate "92" (backslash) at 3 in the string pool.
  line(1) = '9'
  line(2) = '2'
  call addstr (strngs, istrng, line, 1, 2, i, n)
  if (i != 3 && n != 2)
    {
      write (*, '(''internal error'')')
      stop
    }
 
  linno = 0
  colno = LINESZ + 1            # This will trigger a READ.
  npshbk = 0
 
  call scntxt (strngs, istrng, line, linno, colno, pushbk, npshbk)
end
 
######################################################################