A Syntax analyzer transforms a token stream (from the Lexical analyzer)
into a Syntax tree, based on a grammar.

Task[edit]
Take the output from the Lexical analyzer task,
and convert it to an Abstract Syntax Tree (AST),
based on the grammar below. The output should be in a flattened format.

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 parser module/library/class, it would be great
if two versions of the solution are provided: One without the parser module, and one
with.

Grammar
The simple programming language to be analyzed is more or less a (very tiny) subset of
C. The formal grammar in
Extended Backus-Naur Form (EBNF):

 
    stmt_list           =   {stmt} ;
 
    stmt                =   ';'
                          | Identifier '=' expr ';'
                          | 'while' paren_expr stmt
                          | 'if' paren_expr stmt ['else' stmt]
                          | 'print' '(' prt_list ')' ';'
                          | 'putc' paren_expr ';'
                          | '{' stmt_list '}'
                          ;
 
    paren_expr          =   '(' expr ')' ;
 
    prt_list            =   (string | expr) {',' (String | expr)} ;
 
    expr                =   and_expr            {'||' and_expr} ;
    and_expr            =   equality_expr       {'&&' equality_expr} ;
    equality_expr       =   relational_expr     [('==' | '!=') relational_expr] ;
    relational_expr     =   addition_expr       [('<' | '<=' | '>' | '>=') addition_expr] ;
    addition_expr       =   multiplication_expr {('+' | '-') multiplication_expr} ;
    multiplication_expr =   primary             {('*' | '/' | '%') primary } ;
    primary             =   Identifier
                          | Integer
                          | '(' expr ')'
                          | ('+' | '-' | '!') primary
                          ;
The resulting AST should be formulated as a Binary Tree.

Example - given the simple program (below), stored in a file called while.t, create the list of tokens, using one of the Lexical analyzer solutions
lex < while.t > while.lex

Run one of the Syntax analyzer solutions

parse < while.lex > while.ast

The following table shows the input to lex, lex output, and the AST produced by the parser



 Input to lex

 Output from lex, input to parse

 Output from parse



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


    1      1 Identifier      count
    1      7 Op_assign
    1      9 Integer             1
    1     10 Semicolon
    2      1 Keyword_while
    2      7 LeftParen
    2      8 Identifier      count
    2     14 Op_less
    2     16 Integer            10
    2     18 RightParen
    2     20 LeftBrace
    3      5 Keyword_print
    3     10 LeftParen
    3     11 String          "count is: "
    3     23 Comma
    3     25 Identifier      count
    3     30 Comma
    3     32 String          "\n"
    3     36 RightParen
    3     37 Semicolon
    4      5 Identifier      count
    4     11 Op_assign
    4     13 Identifier      count
    4     19 Op_add
    4     21 Integer             1
    4     22 Semicolon
    5      1 RightBrace
    6      1 End_of_input



Sequence
Sequence
;
Assign
Identifier    count
Integer       1
While
Less
Identifier    count
Integer       10
Sequence
Sequence
;
Sequence
Sequence
Sequence
;
Prts
String        "count is: "
;
Prti
Identifier    count
;
Prts
String        "\n"
;
Assign
Identifier    count
Add
Identifier    count
Integer       1


Specifications
List of node type names

Identifier String Integer Sequence If Prtc Prts Prti While Assign Negate Not Multiply Divide Mod
Add Subtract Less LessEqual Greater GreaterEqual Equal NotEqual And Or

In the text below, Null/Empty nodes are represented by ";".

Non-terminal (internal) nodes

For Operators, the following nodes should be created:

Multiply Divide Mod Add Subtract Less LessEqual Greater GreaterEqual Equal NotEqual And Or

For each of the above nodes, the left and right sub-nodes are the operands of the
respective operation.

In pseudo S-Expression format:

(Operator expression expression)

Negate, Not

For these node types, the left node is the operand, and the right node is null.

(Operator expression ;)

Sequence - sub-nodes are either statements or Sequences.

If - left node is the expression, the right node is If node, with it's left node being the
if-true statement part, and the right node being the if-false (else) statement part.

(If expression (If statement else-statement))

If there is not an else, the tree becomes:

(If expression (If statement ;))

Prtc

(Prtc (expression) ;)

Prts

(Prts (String "the string") ;)

Prti

(Prti (Integer 12345) ;)

While - left node is the expression, the right node is the statement.

(While expression statement)

Assign - left node is the left-hand side of the assignment, the right node is the
right-hand side of the assignment.

(Assign Identifier expression)

Terminal (leaf) nodes:

Identifier: (Identifier ident_name)
Integer:    (Integer 12345)
String:     (String "Hello World!")
";":        Empty node

Some simple examples
Sequences denote a list node; they are used to represent a list. semicolon's represent a null node, e.g., the end of this path.

This simple program:

   a=11;

Produces the following AST, encoded as a binary tree:

Under each non-leaf node are two '|' lines. The first represents the left sub-node, the second represents the right sub-node:

   (1) Sequence
   (2)     |-- ;
   (3)     |-- Assign
   (4)         |-- Identifier: a
   (5)         |-- Integer: 11

In flattened form:

   (1) Sequence
   (2) ;
   (3) Assign
   (4) Identifier    a
   (5) Integer       11



This program:

   a=11;
   b=22;
   c=33;

Produces the following AST:

   ( 1) Sequence
   ( 2)     |-- Sequence
   ( 3)     |   |-- Sequence
   ( 4)     |   |   |-- ;
   ( 5)     |   |   |-- Assign
   ( 6)     |   |       |-- Identifier: a
   ( 7)     |   |       |-- Integer: 11
   ( 8)     |   |-- Assign
   ( 9)     |       |-- Identifier: b
   (10)     |       |-- Integer: 22
   (11)     |-- Assign
   (12)         |-- Identifier: c
   (13)         |-- Integer: 33

In flattened form:

   ( 1) Sequence
   ( 2) Sequence
   ( 3) Sequence
   ( 4) ;
   ( 5) Assign
   ( 6) Identifier    a
   ( 7) Integer       11
   ( 8) Assign
   ( 9) Identifier    b
   (10) Integer       22
   (11) Assign
   (12) Identifier    c
   (13) Integer       33

Pseudo-code for the parser. 
Uses Precedence Climbing for expression parsing, and
Recursive Descent for statement parsing. The AST is also built:

def expr(p)
    if tok is "("
        x = paren_expr()
    elif tok in ["-", "+", "!"]
        gettok()
        y = expr(precedence of operator)
        if operator was "+"
            x = y
        else
            x = make_node(operator, y)
    elif tok is an Identifier
        x = make_leaf(Identifier, variable name)
        gettok()
    elif tok is an Integer constant
        x = make_leaf(Integer, integer value)
        gettok()
    else
        error()
 
    while tok is a binary operator and precedence of tok >= p
        save_tok = tok
        gettok()
        q = precedence of save_tok
        if save_tok is not right associative
            q += 1
        x = make_node(Operator save_tok represents, x, expr(q))
 
    return x
 
def paren_expr()
    expect("(")
    x = expr(0)
    expect(")")
    return x
 
def stmt()
    t = NULL
    if accept("if")
        e = paren_expr()
        s = stmt()
        t = make_node(If, e, make_node(If, s, accept("else") ? stmt() : NULL))
    elif accept("putc")
        t = make_node(Prtc, paren_expr())
        expect(";")
    elif accept("print")
        expect("(")
        repeat
            if tok is a string
                e = make_node(Prts, make_leaf(String, the string))
                gettok()
            else
                e = make_node(Prti, expr(0))
 
            t = make_node(Sequence, t, e)
        until not accept(",")
        expect(")")
        expect(";")
    elif tok is ";"
        gettok()
    elif tok is an Identifier
        v = make_leaf(Identifier, variable name)
        gettok()
        expect("=")
        t = make_node(Assign, v, expr(0))
        expect(";")
    elif accept("while")
        e = paren_expr()
        t = make_node(While, e, stmt()
    elif accept("{")
        while tok not equal "}" and tok not equal end-of-file
            t = make_node(Sequence, t, stmt())
        expect("}")
    elif tok is end-of-file
        pass
    else
        error()
    return t
 
def parse()
    t = NULL
    gettok()
    repeat
        t = make_node(Sequence, t, stmt())
    until tok is end-of-file
    return t
Once the AST is built, it should be output in a flattened format. This can be as simple as the following

def prt_ast(t)
    if t == NULL
        print(";\n")
    else
        print(t.node_type)
        if t.node_type in [Identifier, Integer, String]     # leaf node
            print the value of the Ident, Integer or String, "\n"
        else
            print("\n")
            prt_ast(t.left)
            prt_ast(t.right)
If the AST is correctly built, loading it into a subsequent program should be as simple as

def load_ast()
    line = readline()
    # Each line has at least one token
    line_list = tokenize the line, respecting double quotes
 
    text = line_list[0] # first token is always the node type
 
    if text == ";"   # a terminal node
        return NULL
 
    node_type = text # could convert to internal form if desired
 
    # A line with two tokens is a leaf node
    # Leaf nodes are: Identifier, Integer, String
    # The 2nd token is the value
    if len(line_list) > 1
        return make_leaf(node_type, line_list[1])
 
    left = load_ast()
    right = load_ast()
    return make_node(node_type, left, right)
Finally, the AST can also be tested by running it against one of the AST Interpreter solutions.

Test program, assuming this is in a file called prime.t
 lex <prime.t | parse


 Input to lex

 Output from lex, input to parse

 Output from parse



/*
 Simple prime number generator
 */
count = 1;
n = 1;
limit = 100;
while (n < limit) {
    k=3;
    p=1;
    n=n+2;
    while ((k*k<=n) && (p)) {
        p=n/k*k!=n;
        k=k+2;
    }
    if (p) {
        print(n, " is prime\n");
        count = count + 1;
    }
}
print("Total primes found: ", count, "\n");


    4      1 Identifier      count
    4      7 Op_assign
    4      9 Integer             1
    4     10 Semicolon
    5      1 Identifier      n
    5      3 Op_assign
    5      5 Integer             1
    5      6 Semicolon
    6      1 Identifier      limit
    6      7 Op_assign
    6      9 Integer           100
    6     12 Semicolon
    7      1 Keyword_while
    7      7 LeftParen
    7      8 Identifier      n
    7     10 Op_less
    7     12 Identifier      limit
    7     17 RightParen
    7     19 LeftBrace
    8      5 Identifier      k
    8      6 Op_assign
    8      7 Integer             3
    8      8 Semicolon
    9      5 Identifier      p
    9      6 Op_assign
    9      7 Integer             1
    9      8 Semicolon
   10      5 Identifier      n
   10      6 Op_assign
   10      7 Identifier      n
   10      8 Op_add
   10      9 Integer             2
   10     10 Semicolon
   11      5 Keyword_while
   11     11 LeftParen
   11     12 LeftParen
   11     13 Identifier      k
   11     14 Op_multiply
   11     15 Identifier      k
   11     16 Op_lessequal
   11     18 Identifier      n
   11     19 RightParen
   11     21 Op_and
   11     24 LeftParen
   11     25 Identifier      p
   11     26 RightParen
   11     27 RightParen
   11     29 LeftBrace
   12      9 Identifier      p
   12     10 Op_assign
   12     11 Identifier      n
   12     12 Op_divide
   12     13 Identifier      k
   12     14 Op_multiply
   12     15 Identifier      k
   12     16 Op_notequal
   12     18 Identifier      n
   12     19 Semicolon
   13      9 Identifier      k
   13     10 Op_assign
   13     11 Identifier      k
   13     12 Op_add
   13     13 Integer             2
   13     14 Semicolon
   14      5 RightBrace
   15      5 Keyword_if
   15      8 LeftParen
   15      9 Identifier      p
   15     10 RightParen
   15     12 LeftBrace
   16      9 Keyword_print
   16     14 LeftParen
   16     15 Identifier      n
   16     16 Comma
   16     18 String          " is prime\n"
   16     31 RightParen
   16     32 Semicolon
   17      9 Identifier      count
   17     15 Op_assign
   17     17 Identifier      count
   17     23 Op_add
   17     25 Integer             1
   17     26 Semicolon
   18      5 RightBrace
   19      1 RightBrace
   20      1 Keyword_print
   20      6 LeftParen
   20      7 String          "Total primes found: "
   20     29 Comma
   20     31 Identifier      count
   20     36 Comma
   20     38 String          "\n"
   20     42 RightParen
   20     43 Semicolon
   21      1 End_of_input



Sequence
Sequence
Sequence
Sequence
Sequence
;
Assign
Identifier    count
Integer       1
Assign
Identifier    n
Integer       1
Assign
Identifier    limit
Integer       100
While
Less
Identifier    n
Identifier    limit
Sequence
Sequence
Sequence
Sequence
Sequence
;
Assign
Identifier    k
Integer       3
Assign
Identifier    p
Integer       1
Assign
Identifier    n
Add
Identifier    n
Integer       2
While
And
LessEqual
Multiply
Identifier    k
Identifier    k
Identifier    n
Identifier    p
Sequence
Sequence
;
Assign
Identifier    p
NotEqual
Multiply
Divide
Identifier    n
Identifier    k
Identifier    k
Identifier    n
Assign
Identifier    k
Add
Identifier    k
Integer       2
If
Identifier    p
If
Sequence
Sequence
;
Sequence
Sequence
;
Prti
Identifier    n
;
Prts
String        " is prime\n"
;
Assign
Identifier    count
Add
Identifier    count
Integer       1
;
Sequence
Sequence
Sequence
;
Prts
String        "Total primes found: "
;
Prti
Identifier    count
;
Prts
String        "\n"
;


 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
 Lexical Analyzer task
 Code Generator task
 Virtual Machine Interpreter task
 AST Interpreter task

!!!
!!! An implementation of the Rosetta Code parser task:
!!! https://rosettacode.org/wiki/Compiler/syntax_analyzer
!!!
!!! The implementation is based on the published pseudocode.
!!!
 
module compiler_type_kinds
  use, intrinsic :: iso_fortran_env, only: int32
  use, intrinsic :: iso_fortran_env, only: int64
 
  implicit none
  private
 
  ! Synonyms.
  integer, parameter, public :: size_kind = int64
  integer, parameter, public :: length_kind = size_kind
  integer, parameter, public :: nk = size_kind
 
  ! Synonyms for character capable of storing a Unicode code point.
  integer, parameter, public :: unicode_char_kind = selected_char_kind ('ISO_10646')
  integer, parameter, public :: ck = unicode_char_kind
 
  ! Synonyms for integers capable of storing a Unicode code point.
  integer, parameter, public :: unicode_ichar_kind = int32
  integer, parameter, public :: ick = unicode_ichar_kind
end module compiler_type_kinds
 
module string_buffers
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, intrinsic :: iso_fortran_env, only: int64
  use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
 
  implicit none
  private
 
  public :: strbuf_t
 
  type :: strbuf_t
     integer(kind = nk), private :: len = 0
     !
     ! ‘chars’ is made public for efficient access to the individual
     ! characters.
     !
     character(1, kind = ck), allocatable, public :: chars(:)
   contains
     procedure, pass, private :: ensure_storage => strbuf_t_ensure_storage
     procedure, pass :: to_unicode_full_string => strbuf_t_to_unicode_full_string
     procedure, pass :: to_unicode_substring => strbuf_t_to_unicode_substring
     procedure, pass :: length => strbuf_t_length
     procedure, pass :: set => strbuf_t_set
     procedure, pass :: append => strbuf_t_append
     generic :: to_unicode => to_unicode_full_string
     generic :: to_unicode => to_unicode_substring
     generic :: assignment(=) => set
  end type strbuf_t
 
contains
 
  function strbuf_t_to_unicode_full_string (strbuf) result (s)
    class(strbuf_t), intent(in) :: strbuf
    character(:, kind = ck), allocatable :: s
 
    !
    ! This does not actually ensure that the string is valid Unicode;
    ! any 31-bit ‘character’ is supported.
    !
 
    integer(kind = nk) :: i
 
    allocate (character(len = strbuf%len, kind = ck) :: s)
    do i = 1, strbuf%len
       s(i:i) = strbuf%chars(i)
    end do
  end function strbuf_t_to_unicode_full_string
 
  function strbuf_t_to_unicode_substring (strbuf, i, j) result (s)
    !
    ! ‘Extreme’ values of i and j are allowed, as shortcuts for ‘from
    ! the beginning’, ‘up to the end’, or ‘empty substring’.
    !
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i, j
    character(:, kind = ck), allocatable :: s
 
    !
    ! This does not actually ensure that the string is valid Unicode;
    ! any 31-bit ‘character’ is supported.
    !
 
    integer(kind = nk) :: i1, j1
    integer(kind = nk) :: n
    integer(kind = nk) :: k
 
    i1 = max (1_nk, i)
    j1 = min (strbuf%len, j)
    n = max (0_nk, (j1 - i1) + 1_nk)
 
    allocate (character(n, kind = ck) :: s)
    do k = 1, n
       s(k:k) = strbuf%chars(i1 + (k - 1_nk))
    end do
  end function strbuf_t_to_unicode_substring
 
  elemental function strbuf_t_length (strbuf) result (n)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk) :: n
 
    n = strbuf%len
  end function strbuf_t_length
 
  elemental function next_power_of_two (x) result (y)
    integer(kind = nk), intent(in) :: x
    integer(kind = nk) :: y
 
    !
    ! It is assumed that no more than 64 bits are used.
    !
    ! The branch-free algorithm is that of
    ! https://archive.is/nKxAc#RoundUpPowerOf2
    !
    ! Fill in bits until one less than the desired power of two is
    ! reached, and then add one.
    !
 
    y = x - 1
    y = ior (y, ishft (y, -1))
    y = ior (y, ishft (y, -2))
    y = ior (y, ishft (y, -4))
    y = ior (y, ishft (y, -8))
    y = ior (y, ishft (y, -16))
    y = ior (y, ishft (y, -32))
    y = y + 1
  end function next_power_of_two
 
  elemental function new_storage_size (length_needed) result (size)
    integer(kind = nk), intent(in) :: length_needed
    integer(kind = nk) :: size
 
    ! Increase storage by orders of magnitude.
 
    if (2_nk**32 < length_needed) then
       size = huge (1_nk)
    else
       size = next_power_of_two (length_needed)
    end if
  end function new_storage_size
 
  subroutine strbuf_t_ensure_storage (strbuf, length_needed)
    class(strbuf_t), intent(inout) :: strbuf
    integer(kind = nk), intent(in) :: length_needed
 
    integer(kind = nk) :: new_size
    type(strbuf_t) :: new_strbuf
 
    if (.not. allocated (strbuf%chars)) then
       ! Initialize a new strbuf%chars array.
       new_size = new_storage_size (length_needed)
       allocate (strbuf%chars(1:new_size))
    else if (ubound (strbuf%chars, 1) < length_needed) then
       ! Allocate a new strbuf%chars array, larger than the current
       ! one, but containing the same characters.
       new_size = new_storage_size (length_needed)
       allocate (new_strbuf%chars(1:new_size))
       new_strbuf%chars(1:strbuf%len) = strbuf%chars(1:strbuf%len)
       call move_alloc (new_strbuf%chars, strbuf%chars)
    end if
  end subroutine strbuf_t_ensure_storage
 
  subroutine strbuf_t_set (dst, src)
    class(strbuf_t), intent(inout) :: dst
    class(*), intent(in) :: src
 
    integer(kind = nk) :: n
    integer(kind = nk) :: i
 
    select type (src)
    type is (character(*, kind = ck))
       n = len (src, kind = nk)
       call dst%ensure_storage(n)
       do i = 1, n
          dst%chars(i) = src(i:i)
       end do
       dst%len = n
    type is (character(*))
       n = len (src, kind = nk)
       call dst%ensure_storage(n)
       do i = 1, n
          dst%chars(i) = src(i:i)
       end do
       dst%len = n
    class is (strbuf_t)
       n = src%len
       call dst%ensure_storage(n)
       dst%chars(1:n) = src%chars(1:n)
       dst%len = n
    class default
       error stop
    end select
  end subroutine strbuf_t_set
 
  subroutine strbuf_t_append (dst, src)
    class(strbuf_t), intent(inout) :: dst
    class(*), intent(in) :: src
 
    integer(kind = nk) :: n_dst, n_src, n
    integer(kind = nk) :: i
 
    select type (src)
    type is (character(*, kind = ck))
       n_dst = dst%len
       n_src = len (src, kind = nk)
       n = n_dst + n_src
       call dst%ensure_storage(n)
       do i = 1, n_src
          dst%chars(n_dst + i) = src(i:i)
       end do
       dst%len = n
    type is (character(*))
       n_dst = dst%len
       n_src = len (src, kind = nk)
       n = n_dst + n_src
       call dst%ensure_storage(n)
       do i = 1, n_src
          dst%chars(n_dst + i) = src(i:i)
       end do
       dst%len = n
    class is (strbuf_t)
       n_dst = dst%len
       n_src = src%len
       n = n_dst + n_src
       call dst%ensure_storage(n)
       dst%chars((n_dst + 1):n) = src%chars(1:n_src)
       dst%len = n
    class default
       error stop
    end select
  end subroutine strbuf_t_append
 
end module string_buffers
 
module reading_one_line_from_a_stream
  use, intrinsic :: iso_fortran_env, only: input_unit
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
  use, non_intrinsic :: string_buffers
 
  implicit none
  private
 
  ! get_line_from_stream: read an entire input line from a stream into
  ! a strbuf_t.
  public :: get_line_from_stream
 
  character(1, kind = ck), parameter :: linefeed_char = char (10, kind = ck)
 
  ! The following is correct for Unix and its relatives.
  character(1, kind = ck), parameter :: newline_char = linefeed_char
 
contains
 
  subroutine get_line_from_stream (unit_no, eof, no_newline, strbuf)
    integer, intent(in) :: unit_no
    logical, intent(out) :: eof ! End of file?
    logical, intent(out) :: no_newline ! There is a line but it has no
                                       ! newline? (Thus eof also must
                                       ! be .true.)
    class(strbuf_t), intent(inout) :: strbuf
 
    character(1, kind = ck) :: ch
 
    strbuf = ''
    call get_ch (unit_no, eof, ch)
    do while (.not. eof .and. ch /= newline_char)
       call strbuf%append (ch)
       call get_ch (unit_no, eof, ch)
    end do
    no_newline = eof .and. (strbuf%length() /= 0)
  end subroutine get_line_from_stream
 
  subroutine get_ch (unit_no, eof, ch)
    !
    ! Read a single code point from the stream.
    !
    ! Currently this procedure simply inputs ‘ASCII’ bytes rather than
    ! Unicode code points.
    !
    integer, intent(in) :: unit_no
    logical, intent(out) :: eof
    character(1, kind = ck), intent(out) :: ch
 
    integer :: stat
    character(1) :: c = '*'
 
    eof = .false.
 
    if (unit_no == input_unit) then
       call get_input_unit_char (c, stat)
    else
       read (unit = unit_no, iostat = stat) c
    end if
 
    if (stat < 0) then
       ch = ck_'*'
       eof = .true.
    else if (0 < stat) then
       write (error_unit, '("Input error with status code ", I0)') stat
       stop 1
    else
       ch = char (ichar (c, kind = ick), kind = ck)
    end if
  end subroutine get_ch
 
!!!
!!! If you tell gfortran you want -std=f2008 or -std=f2018, you likely
!!! will need to add also -fall-intrinsics or -U__GFORTRAN__
!!!
!!! The first way, you get the FGETC intrinsic. The latter way, you
!!! get the C interface code that uses getchar(3).
!!!
#ifdef __GFORTRAN__
 
  subroutine get_input_unit_char (c, stat)
    !
    ! The following works if you are using gfortran.
    !
    ! (FGETC is considered a feature for backwards compatibility with
    ! g77. However, I know of no way to reconfigure input_unit as a
    ! Fortran 2003 stream, for use with ordinary ‘read’.)
    !
    character, intent(inout) :: c
    integer, intent(out) :: stat
 
    call fgetc (input_unit, c, stat)
  end subroutine get_input_unit_char
 
#else
 
  subroutine get_input_unit_char (c, stat)
    !
    ! An alternative implementation of get_input_unit_char. This
    ! actually reads input from the C standard input, which might not
    ! be the same as input_unit.
    !
    use, intrinsic :: iso_c_binding, only: c_int
    character, intent(inout) :: c
    integer, intent(out) :: stat
 
    interface
       !
       ! Use getchar(3) to read characters from standard input. This
       ! assumes there is actually such a function available, and that
       ! getchar(3) does not exist solely as a macro. (One could write
       ! one’s own getchar() if necessary, of course.)
       !
       function getchar () result (c) bind (c, name = 'getchar')
         use, intrinsic :: iso_c_binding, only: c_int
         integer(kind = c_int) :: c
       end function getchar
    end interface
 
    integer(kind = c_int) :: i_char
 
    i_char = getchar ()
    !
    ! The C standard requires that EOF have a negative value. If the
    ! value returned by getchar(3) is not EOF, then it will be
    ! representable as an unsigned char. Therefore, to check for end
    ! of file, one need only test whether i_char is negative.
    !
    if (i_char < 0) then
       stat = -1
    else
       stat = 0
       c = char (i_char)
    end if
  end subroutine get_input_unit_char
 
#endif
 
end module reading_one_line_from_a_stream
 
module lexer_token_facts
  implicit none
  private
 
  integer, parameter, public :: tk_EOI = 0
  integer, parameter, public :: tk_Mul = 1
  integer, parameter, public :: tk_Div = 2
  integer, parameter, public :: tk_Mod = 3
  integer, parameter, public :: tk_Add = 4
  integer, parameter, public :: tk_Sub = 5
  integer, parameter, public :: tk_Negate = 6
  integer, parameter, public :: tk_Not = 7
  integer, parameter, public :: tk_Lss = 8
  integer, parameter, public :: tk_Leq = 9
  integer, parameter, public :: tk_Gtr = 10
  integer, parameter, public :: tk_Geq = 11
  integer, parameter, public :: tk_Eq = 12
  integer, parameter, public :: tk_Neq = 13
  integer, parameter, public :: tk_Assign = 14
  integer, parameter, public :: tk_And = 15
  integer, parameter, public :: tk_Or = 16
  integer, parameter, public :: tk_If = 17
  integer, parameter, public :: tk_Else = 18
  integer, parameter, public :: tk_While = 19
  integer, parameter, public :: tk_Print = 20
  integer, parameter, public :: tk_Putc = 21
  integer, parameter, public :: tk_Lparen = 22
  integer, parameter, public :: tk_Rparen = 23
  integer, parameter, public :: tk_Lbrace = 24
  integer, parameter, public :: tk_Rbrace = 25
  integer, parameter, public :: tk_Semi = 26
  integer, parameter, public :: tk_Comma = 27
  integer, parameter, public :: tk_Ident = 28
  integer, parameter, public :: tk_Integer = 29
  integer, parameter, public :: tk_String = 30
  integer, parameter, public :: tk_Positive = 31
 
  character(16), parameter, public :: lexer_token_string(0:31) = &
       (/ "EOI             ",   &
       &  "*               ",   &
       &  "/               ",   &
       &  "%               ",   &
       &  "+               ",   &
       &  "-               ",   &
       &  "-               ",   &
       &  "!               ",   &
       &  "<               ",   &
       &  "<=              ",   &
       &  ">               ",   &
       &  ">=              ",   &
       &  "==              ",   &
       &  "!=              ",   &
       &  "=               ",   &
       &  "&&              ",   &
       &  "||              ",   &
       &  "if              ",   &
       &  "else            ",   &
       &  "while           ",   &
       &  "print           ",   &
       &  "putc            ",   &
       &  "(               ",   &
       &  ")               ",   &
       &  "{               ",   &
       &  "}               ",   &
       &  ";               ",   &
       &  ",               ",   &
       &  "Ident           ",   &
       &  "Integer literal ",   &
       &  "String literal  ",   &
       &  "+               " /)
 
  integer, parameter, public :: lexer_token_arity(0:31) = &
       & (/ -1,                   & ! EOI
       &    2, 2, 2, 2, 2,        & ! * / % + -
       &    1, 1,                 & ! negate !
       &    2, 2, 2, 2, 2, 2,     & ! < <= > >= == !=
       &    -1,                   & ! =
       &    2, 2,                 & ! && ||
       &    -1, -1, -1, -1, -1,   & !
       &    -1, -1, -1, -1, -1,   & !
       &    -1, -1, -1, -1,       & !
       &    1 /)                    ! positive
 
  integer, parameter, public :: lexer_token_precedence(0:31) = &
       & (/ -1,                   & ! EOI
       &    13, 13, 13,           & ! * / %
       &    12, 12,               & ! + -
       &    14, 14,               & ! negate !
       &    10, 10, 10, 10,       & ! < <= > >=
       &    9, 9,                 & ! == !=
       &    -1,                   & ! =
       &    5,                    & ! &&
       &    4,                    & ! ||
       &    -1, -1, -1, -1, -1,   & !
       &    -1, -1, -1, -1, -1,   & !
       &    -1, -1, -1, -1,       & !
       &    14 /)                   ! positive
 
  integer, parameter, public :: left_associative = 0
  integer, parameter, public :: right_associative = 1
 
  ! All current operators are left associative. (The values in the
  ! array for things that are not operators are unimportant.)
  integer, parameter, public :: lexer_token_associativity(0:31) = left_associative
 
end module lexer_token_facts
 
module reading_of_lexer_tokens
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
  use, non_intrinsic :: string_buffers
  use, non_intrinsic :: reading_one_line_from_a_stream
  use, non_intrinsic :: lexer_token_facts
 
  implicit none
  private  
 
  public :: lexer_token_t
  public :: get_lexer_token
 
  character(1, kind = ck), parameter :: horizontal_tab_char = char (9, kind = ck)
  character(1, kind = ck), parameter :: linefeed_char = char (10, kind = ck)
  character(1, kind = ck), parameter :: vertical_tab_char = char (11, kind = ck)
  character(1, kind = ck), parameter :: formfeed_char = char (12, kind = ck)
  character(1, kind = ck), parameter :: carriage_return_char = char (13, kind = ck)
  character(1, kind = ck), parameter :: space_char = ck_' '
 
  type :: lexer_token_t
     integer :: token_no = -(huge (1))
     character(:, kind = ck), allocatable :: val
     integer(nk) :: line_no = -(huge (1_nk))
     integer(nk) :: column_no = -(huge (1_nk))
  end type lexer_token_t
 
contains
 
  subroutine get_lexer_token (unit_no, lex_line_no, eof, token)
    !
    ! Lines that are empty or contain only whitespace are tolerated.
    !
    ! Also tolerated are comment lines, whose first character is a
    ! '!'. It is convenient for debugging to be able to comment out
    ! lines.
    !
    ! A last line be without a newline is *not* tolerated, unless it
    ! contains only whitespace.
    !
    ! Letting there be some whitespace is partly for the sake of
    ! reading cut-and-paste from a browser display.
    !
    integer, intent(in) :: unit_no
    integer(kind = nk), intent(inout) :: lex_line_no
    logical, intent(out) :: eof
    type(lexer_token_t), intent(out) :: token
 
    type(strbuf_t) :: strbuf
    logical :: no_newline
    logical :: input_found
 
    ! Let a negative setting initialize the line number.
    lex_line_no = max (0_nk, lex_line_no)
 
    strbuf = ''
    eof = .false.
    input_found = .false.
    do while (.not. eof .and. .not. input_found)
       call get_line_from_stream (unit_no, eof, no_newline, strbuf)
       if (eof) then
          if (no_newline) then
             lex_line_no = lex_line_no + 1
             if (.not. strbuf_is_all_whitespace (strbuf)) then
                call start_error_message (lex_line_no)
                write (error_unit, '("lexer line ends without a newline")')
                stop 1
             end if
          end if
       else
          lex_line_no = lex_line_no + 1
          input_found = .true.
          if (strbuf_is_all_whitespace (strbuf)) then
             ! A blank line.
             input_found = .false.
          else if (0 < strbuf%length()) then
             if (strbuf%chars(1) == ck_'!') then
                ! A comment line.
                input_found = .false.
             end if
          end if
       end if
    end do
 
    token = lexer_token_t ()
    if (.not. eof) then
       token = strbuf_to_token (lex_line_no, strbuf)
    end if
  end subroutine get_lexer_token
 
  function strbuf_to_token (lex_line_no, strbuf) result (token)
    integer(kind = nk), intent(in) :: lex_line_no
    class(strbuf_t), intent(in) :: strbuf
    type(lexer_token_t) :: token
 
    character(:, kind = ck), allocatable :: line_no
    character(:, kind = ck), allocatable :: column_no
    character(:, kind = ck), allocatable :: token_name
    character(:, kind = ck), allocatable :: val_string
    integer :: stat
    integer(kind = nk) :: n
 
    call split_line (lex_line_no, strbuf, line_no, column_no, token_name, val_string)
 
    read (line_no, *, iostat = stat) token%line_no
    if (stat /= 0) then
       call start_error_message (lex_line_no)
       write (error_unit, '("line number field is unreadable or too large")')
       stop 1
    end if
 
    read (column_no, *, iostat = stat) token%column_no
    if (stat /= 0) then
       call start_error_message (lex_line_no)
       write (error_unit, '("column number field is unreadable or too large")')
       stop 1
    end if
 
    token%token_no = token_name_to_token_no (lex_line_no, token_name)
 
    select case (token%token_no)
    case (tk_Ident)
       ! I do no checking of identifier names.
       allocate (token%val, source = val_string)
    case (tk_Integer)
       call check_is_all_digits (lex_line_no, val_string)
       allocate (token%val, source = val_string)
    case (tk_String)
       n = len (val_string, kind = nk)
       if (n < 2) then
          call string_literal_missing_or_no_good
       else if (val_string(1:1) /= ck_'"' .or. val_string(n:n) /= ck_'"') then
          call string_literal_missing_or_no_good
       else
          allocate (token%val, source = val_string)
       end if
    case default
       if (len (val_string, kind = nk) /= 0) then
          call start_error_message (lex_line_no)
          write (error_unit, '("token should not have a value")')
          stop 1
       end if
    end select
 
  contains
 
    subroutine string_literal_missing_or_no_good
      call start_error_message (lex_line_no)
      write (error_unit, '("""String"" token requires a string literal")')
      stop 1
    end subroutine string_literal_missing_or_no_good
 
  end function strbuf_to_token
 
  subroutine split_line (lex_line_no, strbuf, line_no, column_no, token_name, val_string)
    integer(kind = nk), intent(in) :: lex_line_no
    class(strbuf_t), intent(in) :: strbuf
    character(:, kind = ck), allocatable, intent(out) :: line_no
    character(:, kind = ck), allocatable, intent(out) :: column_no
    character(:, kind = ck), allocatable, intent(out) :: token_name
    character(:, kind = ck), allocatable, intent(out) :: val_string
 
    integer(kind = nk) :: i, j
 
    i = skip_whitespace (strbuf, 1_nk)
    j = skip_non_whitespace (strbuf, i)
    line_no = strbuf%to_unicode(i, j - 1)
    call check_is_all_digits (lex_line_no, line_no)
 
    i = skip_whitespace (strbuf, j)
    j = skip_non_whitespace (strbuf, i)
    column_no = strbuf%to_unicode(i, j - 1)
    call check_is_all_digits (lex_line_no, column_no)
 
    i = skip_whitespace (strbuf, j)
    j = skip_non_whitespace (strbuf, i)
    token_name = strbuf%to_unicode(i, j - 1)
 
    i = skip_whitespace (strbuf, j)
    if (strbuf%length() < i) then
       val_string = ck_''
    else if (strbuf%chars(i) == ck_'"') then
       j = skip_whitespace_backwards (strbuf, strbuf%length())
       if (strbuf%chars(j) == ck_'"') then
          val_string = strbuf%to_unicode(i, j)
       else
          call start_error_message (lex_line_no)
          write (error_unit, '("string literal does not end in a double quote")')
          stop 1
       end if
    else
       j = skip_non_whitespace (strbuf, i)
       val_string = strbuf%to_unicode(i, j - 1)
       i = skip_whitespace (strbuf, j)
       if (i <= strbuf%length()) then
          call start_error_message (lex_line_no)
          write (error_unit, '("token line contains unexpected text")')
          stop 1
       end if
    end if
  end subroutine split_line
 
  function token_name_to_token_no (lex_line_no, token_name) result (token_no)
    integer(kind = nk), intent(in) :: lex_line_no
    character(*, kind = ck), intent(in) :: token_name
    integer :: token_no
 
    !!
    !! This implementation is not optimized in any way, unless the
    !! Fortran compiler can optimize the SELECT CASE.
    !!
 
    select case (token_name)
    case (ck_"End_of_input")
       token_no = tk_EOI
    case (ck_"Op_multiply")
       token_no = tk_Mul
    case (ck_"Op_divide")
       token_no = tk_Div
    case (ck_"Op_mod")
       token_no = tk_Mod
    case (ck_"Op_add")
       token_no = tk_Add
    case (ck_"Op_subtract")
       token_no = tk_Sub
    case (ck_"Op_negate")
       token_no = tk_Negate
    case (ck_"Op_not")
       token_no = tk_Not
    case (ck_"Op_less")
       token_no = tk_Lss
    case (ck_"Op_lessequal    ")
       token_no = tk_Leq
    case (ck_"Op_greater")
       token_no = tk_Gtr
    case (ck_"Op_greaterequal")
       token_no = tk_Geq
    case (ck_"Op_equal")
       token_no = tk_Eq
    case (ck_"Op_notequal")
       token_no = tk_Neq
    case (ck_"Op_assign")
       token_no = tk_Assign
    case (ck_"Op_and")
       token_no = tk_And
    case (ck_"Op_or")
       token_no = tk_Or
    case (ck_"Keyword_if")
       token_no = tk_If
    case (ck_"Keyword_else")
       token_no = tk_Else
    case (ck_"Keyword_while")
       token_no = tk_While
    case (ck_"Keyword_print")
       token_no = tk_Print
    case (ck_"Keyword_putc")
       token_no = tk_Putc
    case (ck_"LeftParen")
       token_no = tk_Lparen
    case (ck_"RightParen")
       token_no = tk_Rparen
    case (ck_"LeftBrace")
       token_no = tk_Lbrace
    case (ck_"RightBrace")
       token_no = tk_Rbrace
    case (ck_"Semicolon")
       token_no = tk_Semi
    case (ck_"Comma")
       token_no = tk_Comma
    case (ck_"Identifier")
       token_no = tk_Ident
    case (ck_"Integer")
       token_no = tk_Integer
    case (ck_"String")
       token_no = tk_String
    case default
       call start_error_message (lex_line_no)
       write (error_unit, '("unrecognized token name: ", A)') token_name
       stop 1
    end select
  end function token_name_to_token_no
 
  function skip_whitespace (strbuf, i) result (j)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    integer(kind = nk) :: j
 
    logical :: done
 
    j = i
    done = .false.
    do while (.not. done)
       if (at_end_of_line (strbuf, j)) then
          done = .true.
       else if (.not. isspace (strbuf%chars(j))) then
          done = .true.
       else
          j = j + 1
       end if
    end do
  end function skip_whitespace
 
  function skip_non_whitespace (strbuf, i) result (j)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    integer(kind = nk) :: j
 
    logical :: done
 
    j = i
    done = .false.
    do while (.not. done)
       if (at_end_of_line (strbuf, j)) then
          done = .true.
       else if (isspace (strbuf%chars(j))) then
          done = .true.
       else
          j = j + 1
       end if
    end do
  end function skip_non_whitespace
 
  function skip_whitespace_backwards (strbuf, i) result (j)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    integer(kind = nk) :: j
 
    logical :: done
 
    j = i
    done = .false.
    do while (.not. done)
       if (j == -1) then
          done = .true.
       else if (.not. isspace (strbuf%chars(j))) then
          done = .true.
       else
          j = j - 1
       end if
    end do
  end function skip_whitespace_backwards
 
  function at_end_of_line (strbuf, i) result (bool)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    logical :: bool
 
    bool = (strbuf%length() < i)
  end function at_end_of_line
 
  elemental function strbuf_is_all_whitespace (strbuf) result (bool)
    class(strbuf_t), intent(in) :: strbuf
    logical :: bool
 
    integer(kind = nk) :: n
    integer(kind = nk) :: i
 
    n = strbuf%length()
    if (n == 0) then
       bool = .true.
    else
       i = 1
       bool = .true.
       do while (bool .and. i /= n + 1)
          bool = isspace (strbuf%chars(i))
          i = i + 1
       end do
    end if
  end function strbuf_is_all_whitespace
 
  elemental function isspace (ch) result (bool)
    character(1, kind = ck), intent(in) :: ch
    logical :: bool
 
    bool = (ch == horizontal_tab_char) .or.  &
         & (ch == linefeed_char) .or.        &
         & (ch == vertical_tab_char) .or.    &
         & (ch == formfeed_char) .or.        &
         & (ch == carriage_return_char) .or. &
         & (ch == space_char)
  end function isspace
 
  elemental function isdigit (ch) result (bool)
    character(1, kind = ck), intent(in) :: ch
    logical :: bool
 
    integer(kind = ick), parameter :: zero = ichar (ck_'0', kind = ick)
    integer(kind = ick), parameter :: nine = ichar (ck_'9', kind = ick)
 
    integer(kind = ick) :: i_ch
 
    i_ch = ichar (ch, kind = ick)
    bool = (zero <= i_ch .and. i_ch <= nine)
  end function isdigit
 
  subroutine check_is_all_digits (lex_line_no, str)
    integer(kind = nk), intent(in) :: lex_line_no
    character(*, kind = ck), intent(in) :: str
 
    integer(kind = nk) :: n
    integer(kind = nk) :: i
 
    n = len (str, kind = nk)
    if (n == 0_nk) then
       call start_error_message (lex_line_no)
       write (error_unit, '("a required field is missing")')
       stop 1
    else
       do i = 1, n
          if (.not. isdigit (str(i:i))) then
             call start_error_message (lex_line_no)
             write (error_unit, '("a numeric field contains a non-digit")')
             stop 1
          end if
       end do
    end if
  end subroutine check_is_all_digits
 
  subroutine start_error_message (lex_line_no)
    integer(kind = nk), intent(in) :: lex_line_no
 
    write (error_unit, '("Token stream error at line ", I0, ": ")', advance = 'no') &
         &    lex_line_no
  end subroutine start_error_message
 
end module reading_of_lexer_tokens
 
module syntactic_analysis
  use, intrinsic :: iso_fortran_env, only: input_unit
  use, intrinsic :: iso_fortran_env, only: output_unit
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
  use, non_intrinsic :: string_buffers
  use, non_intrinsic :: lexer_token_facts
  use, non_intrinsic :: reading_of_lexer_tokens
 
  implicit none
  private
 
  public :: ast_node_t
  public :: ast_t
  public :: parse_token_stream
  public :: output_ast_flattened
 
  integer, parameter, public :: tk_start_of_statement = -1
  integer, parameter, public :: tk_primary = -2
 
  integer, parameter :: node_Identifier = 1
  integer, parameter :: node_String = 2
  integer, parameter :: node_Integer = 3
  integer, parameter :: node_Sequence = 4
  integer, parameter :: node_If = 5
  integer, parameter :: node_Prtc = 6
  integer, parameter :: node_Prts = 7
  integer, parameter :: node_Prti = 8
  integer, parameter :: node_While = 9
  integer, parameter :: node_Assign = 10
  integer, parameter :: node_Negate = 11
  integer, parameter :: node_Not = 12
  integer, parameter :: node_Multiply = 13
  integer, parameter :: node_Divide = 14
  integer, parameter :: node_Mod = 15
  integer, parameter :: node_Add = 16
  integer, parameter :: node_Subtract = 17
  integer, parameter :: node_Less = 18
  integer, parameter :: node_LessEqual = 19
  integer, parameter :: node_Greater = 20
  integer, parameter :: node_GreaterEqual = 21
  integer, parameter :: node_Equal = 22
  integer, parameter :: node_NotEqual = 23
  integer, parameter :: node_And = 24
  integer, parameter :: node_Or = 25
 
  character(16), parameter :: node_variety_string(1:25) = &
       (/ "Identifier      ",    &
       &  "String          ",    &
       &  "Integer         ",    &
       &  "Sequence        ",    &
       &  "If              ",    &
       &  "Prtc            ",    &
       &  "Prts            ",    &
       &  "Prti            ",    &
       &  "While           ",    &
       &  "Assign          ",    &
       &  "Negate          ",    &
       &  "Not             ",    &
       &  "Multiply        ",    &
       &  "Divide          ",    &
       &  "Mod             ",    &
       &  "Add             ",    &
       &  "Subtract        ",    &
       &  "Less            ",    &
       &  "LessEqual       ",    &
       &  "Greater         ",    &
       &  "GreaterEqual    ",    &
       &  "Equal           ",    &
       &  "NotEqual        ",    &
       &  "And             ",    &
       &  "Or              " /)
 
  type :: ast_node_t
     integer :: node_variety
     character(:, kind = ck), allocatable :: val
     type(ast_node_t), pointer :: left => null ()
     type(ast_node_t), pointer :: right => null ()
   contains
     procedure, pass :: assign => ast_node_t_assign
     generic :: assignment(=) => assign
     final :: ast_node_t_finalize
  end type ast_node_t
 
  ! ast_t phases.
  integer, parameter :: building = 1
  integer, parameter :: completed = 2
 
  type :: ast_t
     !
     ! This type is used to build the subtrees, as well as for the
     ! completed AST. The difference is in the setting of ‘phase’.
     !
     type(ast_node_t), pointer :: node => null ()
     integer, private :: phase = building
   contains
     procedure, pass :: assign => ast_t_assign
     generic :: assignment(=) => assign
     final :: ast_t_finalize
  end type ast_t
 
  type(ast_t), parameter :: ast_nil = ast_t (null ())
 
contains
 
  recursive subroutine ast_node_t_assign (node, other)
    class(ast_node_t), intent(out) :: node
    class(*), intent(in) :: other
 
    select type (other)
    class is (ast_node_t)
       node%node_variety = other%node_variety
       if (allocated (other%val)) allocate (node%val, source = other%val)
       if (associated (other%left)) allocate (node%left, source = other%left)
       if (associated (other%right)) allocate (node%right, source = other%right)
    class default
       ! This branch should never be reached.
       error stop
    end select
  end subroutine ast_node_t_assign
 
  recursive subroutine ast_node_t_finalize (node)
    type(ast_node_t), intent(inout) :: node
 
    if (associated (node%left)) deallocate (node%left)
    if (associated (node%right)) deallocate (node%right)
  end subroutine ast_node_t_finalize
 
  recursive subroutine ast_t_assign (ast, other)
    class(ast_t), intent(out) :: ast
    class(*), intent(in) :: other
 
    select type (other)
    class is (ast_t)
       if (associated (other%node)) allocate (ast%node, source = other%node)
       !
       ! Whether it is better to set phase to ‘building’ or to set it
       ! to ‘other%phase’ is unclear to me. Probably ‘building’ is the
       ! better choice. Which variable controls memory recovery is
       ! clear and unchanging, in that case: it is the original,
       ! ‘other’, that does.
       !
       ast%phase = building
    class default
       ! This should not happen.
       error stop
    end select
  end subroutine ast_t_assign
 
  subroutine ast_t_finalize (ast)
    type(ast_t), intent(inout) :: ast
 
    !
    ! When we are building the tree, the tree’s nodes should not be
    ! deallocated when the ast_t variable temporarily holding them
    ! goes out of scope.
    !
    ! However, once the AST is completed, we do want the memory
    ! recovered when the variable goes out of scope.
    !
    ! (Elsewhere I have written a primitive garbage collector for
    ! Fortran programs, but in this case it would be a lot of overhead
    ! for little gain. In fact, we could reasonably just let the
    ! memory leak, in this program.
    !
    ! Fortran runtimes *are* allowed by the standard to have garbage
    ! collectors built in. To my knowledge, at the time of this
    ! writing, only NAG Fortran has a garbage collector option.)
    !
 
    if (ast%phase == completed) then
       if (associated (ast%node)) deallocate (ast%node)
    end if
  end subroutine ast_t_finalize
 
  function parse_token_stream (unit_no) result (ast)
    integer, intent(in) :: unit_no
    type(ast_t) :: ast
 
    integer(kind = nk) :: lex_line_no
    type(ast_t) :: statement
    type(lexer_token_t) :: token
 
    lex_line_no = -1_nk
    call get_token (unit_no, lex_line_no, token)
    call parse_statement (unit_no, lex_line_no, token, statement)
    ast = make_internal_node (node_Sequence, ast, statement)
    do while (token%token_no /= tk_EOI)
       call parse_statement (unit_no, lex_line_no, token, statement)
       ast = make_internal_node (node_Sequence, ast, statement)
    end do
    ast%phase = completed
  end function parse_token_stream
 
  recursive subroutine parse_statement (unit_no, lex_line_no, token, ast)
    integer, intent(in) :: unit_no
    integer(kind = nk), intent(inout) :: lex_line_no
    type(lexer_token_t), intent(inout) :: token
    type(ast_t), intent(out) :: ast
 
    ast = ast_nil
 
    select case (token%token_no)
    case (tk_If)
       call parse_ifelse_construct
    case (tk_Putc)
       call parse_putc
    case (tk_Print)
       call parse_print
    case (tk_Semi)
       call get_token (unit_no, lex_line_no, token)
    case (tk_Ident)
       call parse_identifier
    case (tk_While)
       call parse_while_construct
    case (tk_Lbrace)
       call parse_lbrace_construct
    case (tk_EOI)
       continue
    case default
       call syntax_error_message ("", tk_start_of_statement, token)
       stop 1
    end select
 
  contains
 
    recursive subroutine parse_ifelse_construct
      type(ast_t) :: predicate
      type(ast_t) :: statement_for_predicate_true
      type(ast_t) :: statement_for_predicate_false
 
      call expect_token ("If", tk_If, token)
      call get_token (unit_no, lex_line_no, token)
      call parse_parenthesized_expression (unit_no, lex_line_no, token, predicate)
      call parse_statement (unit_no, lex_line_no, token, statement_for_predicate_true)
      if (token%token_no == tk_Else) then
         call get_token (unit_no, lex_line_no, token)
         call parse_statement (unit_no, lex_line_no, token, statement_for_predicate_false)
         ast = make_internal_node (node_If, statement_for_predicate_true, &
              &                    statement_for_predicate_false)
      else
         ast = make_internal_node (node_If, statement_for_predicate_true, ast_nil)
      end if
      ast = make_internal_node (node_If, predicate, ast)
    end subroutine parse_ifelse_construct
 
    recursive subroutine parse_putc
      type(ast_t) :: arguments
 
      call expect_token ("Putc", tk_Putc, token)
      call get_token (unit_no, lex_line_no, token)
      call parse_parenthesized_expression (unit_no, lex_line_no, token, arguments)
      ast = make_internal_node (node_Prtc, arguments, ast_nil)
      call expect_token ("Putc", tk_Semi, token)
      call get_token (unit_no, lex_line_no, token)
    end subroutine parse_putc
 
    recursive subroutine parse_print
      logical :: done
      type(ast_t) :: arg
      type(ast_t) :: printer
 
      call expect_token ("Print", tk_Print, token)
      call get_token (unit_no, lex_line_no, token)
      call expect_token ("Print", tk_Lparen, token)
      done = .false.
      do while (.not. done)
         call get_token (unit_no, lex_line_no, token)
         select case (token%token_no)
         case (tk_String)
            arg = make_leaf_node (node_String, token%val)
            printer = make_internal_node (node_Prts, arg, ast_nil)
            call get_token (unit_no, lex_line_no, token)
         case default
            call parse_expression (unit_no, 0, lex_line_no, token, arg)
            printer = make_internal_node (node_Prti, arg, ast_nil)
         end select
         ast = make_internal_node (node_Sequence, ast, printer)
         done = (token%token_no /= tk_Comma)
      end do
      call expect_token ("Print", tk_Rparen, token)
      call get_token (unit_no, lex_line_no, token)
      call expect_token ("Print", tk_Semi, token)
      call get_token (unit_no, lex_line_no, token)
    end subroutine parse_print
 
    recursive subroutine parse_identifier
      type(ast_t) :: left_side
      type(ast_t) :: right_side
 
      left_side = make_leaf_node (node_Identifier, token%val)
      call get_token (unit_no, lex_line_no, token)
      call expect_token ("assign", tk_Assign, token)
      call get_token (unit_no, lex_line_no, token)
      call parse_expression (unit_no, 0, lex_line_no, token, right_side)
      ast = make_internal_node (node_Assign, left_side, right_side)
      call expect_token ("assign", tk_Semi, token)
      call get_token (unit_no, lex_line_no, token)
    end subroutine parse_identifier
 
    recursive subroutine parse_while_construct
      type(ast_t) :: predicate
      type(ast_t) :: statement_to_be_repeated
 
      call expect_token ("While", tk_While, token)
      call get_token (unit_no, lex_line_no, token)
      call parse_parenthesized_expression (unit_no, lex_line_no, token, predicate)
      call parse_statement (unit_no, lex_line_no, token, statement_to_be_repeated)
      ast = make_internal_node (node_While, predicate, statement_to_be_repeated)
    end subroutine parse_while_construct
 
    recursive subroutine parse_lbrace_construct
      type(ast_t) :: statement
 
      call expect_token ("Lbrace", tk_Lbrace, token)
      call get_token (unit_no, lex_line_no, token)
      do while (token%token_no /= tk_Rbrace .and. token%token_no /= tk_EOI)
         call parse_statement (unit_no, lex_line_no, token, statement)
         ast = make_internal_node (node_Sequence, ast, statement)
      end do
      call expect_token ("Lbrace", tk_Rbrace, token)
      call get_token (unit_no, lex_line_no, token)
    end subroutine parse_lbrace_construct
 
  end subroutine parse_statement
 
  recursive subroutine parse_expression (unit_no, p, lex_line_no, token, ast)
    integer, intent(in) :: unit_no
    integer, intent(in) :: p
    integer(kind = nk), intent(inout) :: lex_line_no
    type(lexer_token_t), intent(inout) :: token
    type(ast_t), intent(out) :: ast
 
    integer :: precedence
    type(ast_t) :: expression
 
    select case (token%token_no)
    case (tk_Lparen)
       call parse_parenthesized_expression (unit_no, lex_line_no, token, ast)
    case (tk_Sub)
       token%token_no = tk_Negate
       precedence = lexer_token_precedence(token%token_no)
       call get_token (unit_no, lex_line_no, token)
       call parse_expression (unit_no, precedence, lex_line_no, token, expression)
       ast = make_internal_node (node_Negate, expression, ast_nil)
    case (tk_Add)
       token%token_no = tk_Positive
       precedence = lexer_token_precedence(token%token_no)
       call get_token (unit_no, lex_line_no, token)
       call parse_expression (unit_no, precedence, lex_line_no, token, expression)
       ast = expression
    case (tk_Not)
       precedence = lexer_token_precedence(token%token_no)
       call get_token (unit_no, lex_line_no, token)
       call parse_expression (unit_no, precedence, lex_line_no, token, expression)
       ast = make_internal_node (node_Not, expression, ast_nil)
    case (tk_Ident)
       ast = make_leaf_node (node_Identifier, token%val)
       call get_token (unit_no, lex_line_no, token)
    case (tk_Integer)
       ast = make_leaf_node (node_Integer, token%val)
       call get_token (unit_no, lex_line_no, token)
    case default
       call syntax_error_message ("", tk_primary, token)
       stop 1
    end select
 
    do while (lexer_token_arity(token%token_no) == 2 .and. &
         &    p <= lexer_token_precedence(token%token_no))
       block
         type(ast_t) :: right_expression
         integer :: q
         integer :: node_variety
 
         if (lexer_token_associativity(token%token_no) == right_associative) then
            q = lexer_token_precedence(token%token_no)
         else
            q = lexer_token_precedence(token%token_no) + 1
         end if
         node_variety = binary_operator_node_variety (token%token_no)
         call get_token (unit_no, lex_line_no, token)
         call parse_expression (unit_no, q, lex_line_no, token, right_expression)
         ast = make_internal_node (node_variety, ast, right_expression)
       end block
    end do
  end subroutine parse_expression
 
  recursive subroutine parse_parenthesized_expression (unit_no, lex_line_no, token, ast)
    integer, intent(in) :: unit_no
    integer(kind = nk), intent(inout) :: lex_line_no
    type(lexer_token_t), intent(inout) :: token
    type(ast_t), intent(out) :: ast
 
    call expect_token ("paren_expr", tk_Lparen, token)
    call get_token (unit_no, lex_line_no, token)
    call parse_expression (unit_no, 0, lex_line_no, token, ast)
    call expect_token ("paren_expr", tk_Rparen, token)
    call get_token (unit_no, lex_line_no, token)
  end subroutine parse_parenthesized_expression
 
  elemental function binary_operator_node_variety (token_no) result (node_variety)
    integer, intent(in) :: token_no
    integer :: node_variety
 
    select case (token_no)
    case (tk_Mul)
       node_variety = node_Multiply
    case (tk_Div)
       node_variety = node_Divide
    case (tk_Mod)
       node_variety = node_Mod
    case (tk_Add)
       node_variety = node_Add
    case (tk_Sub)
       node_variety = node_Subtract
    case (tk_Lss)
       node_variety = node_Less
    case (tk_Leq)
       node_variety = node_LessEqual
    case (tk_Gtr)
       node_variety = node_Greater
    case (tk_Geq)
       node_variety = node_GreaterEqual
    case (tk_Eq)
       node_variety = node_Equal
    case (tk_Neq)
       node_variety = node_NotEqual
    case (tk_And)
       node_variety = node_And
    case (tk_Or)
       node_variety = node_Or
    case default
       ! This branch should never be reached.
       error stop
    end select
  end function binary_operator_node_variety
 
  function make_internal_node (node_variety, left, right) result (ast)
    integer, intent(in) :: node_variety
    class(ast_t), intent(in) :: left, right
    type(ast_t) :: ast
 
    type(ast_node_t), pointer :: node
 
    allocate (node)
    node%node_variety = node_variety
    node%left => left%node
    node%right => right%node
    ast%node => node
  end function make_internal_node
 
  function make_leaf_node (node_variety, val) result (ast)
    integer, intent(in) :: node_variety
    character(*, kind = ck), intent(in) :: val
    type(ast_t) :: ast
 
    type(ast_node_t), pointer :: node
 
    allocate (node)
    node%node_variety = node_variety
    node%val = val
    ast%node => node
  end function make_leaf_node
 
  subroutine get_token (unit_no, lex_line_no, token)
    integer, intent(in) :: unit_no
    integer(kind = nk), intent(inout) :: lex_line_no
    type(lexer_token_t), intent(out) :: token
 
    logical :: eof
 
    call get_lexer_token (unit_no, lex_line_no, eof, token)
    if (eof) then
       write (error_unit, '("Parser error: the stream of input tokens is incomplete")')
       stop 1
    end if
  end subroutine get_token
 
  subroutine expect_token (message, token_no, token)
    character(*), intent(in) :: message
    integer, intent (in) :: token_no
    class(lexer_token_t), intent(in) :: token
 
    if (token%token_no /= token_no) then
       call syntax_error_message (message, token_no, token)
       stop 1
    end if
  end subroutine expect_token
 
  subroutine syntax_error_message (message, expected_token_no, token)
    character(*), intent(in) :: message
    integer, intent(in) :: expected_token_no
    class(lexer_token_t), intent(in) :: token
 
    ! Write a message to an output unit dedicated to printing
    ! errors. The message could, of course, be more detailed than what
    ! we are doing here.
    write (error_unit, '("Syntax error at ", I0, ".", I0)') &
         &    token%line_no, token%column_no
 
    !
    ! For the sake of the exercise, also write, to output_unit, a
    ! message in the style of the C reference program.
    !
    write (output_unit, '("(", I0, ", ", I0, ") error: ")', advance = 'no') &
         &    token%line_no, token%column_no
    select case (expected_token_no)
    case (tk_start_of_statement)
       write (output_unit, '("expecting start of statement, found ''", 1A, "''")') &
            &    trim (lexer_token_string(token%token_no))
    case (tk_primary)
       write (output_unit, '("Expecting a primary, found ''", 1A, "''")') &
            &    trim (lexer_token_string(token%token_no))
    case default
       write (output_unit, '(1A, ": Expecting ''", 1A, "'', found ''", 1A, "''")') &
            &    trim (message), trim (lexer_token_string(expected_token_no)), &
            &    trim (lexer_token_string(token%token_no))
    end select
  end subroutine syntax_error_message
 
  subroutine output_ast_flattened (unit_no, ast)
    integer, intent(in) :: unit_no
    type(ast_t), intent(in) :: ast
 
    call output_ast_node_flattened (unit_no, ast%node)
  end subroutine output_ast_flattened
 
  recursive subroutine output_ast_node_flattened (unit_no, node)
    integer, intent(in) :: unit_no
    type(ast_node_t), pointer, intent(in) :: node
 
      if (.not. associated (node)) then
         write (unit_no, '(";")')
      else
         if (allocated (node%val)) then
            write (unit_no, '(1A16, 2X, 1A)') &
                 &   node_variety_string(node%node_variety), node%val
         else
            write (unit_no, '(1A)') &
                 &   trim (node_variety_string(node%node_variety))
            call output_ast_node_flattened (unit_no, node%left)
            call output_ast_node_flattened (unit_no, node%right)
         end if
      end if
    end subroutine output_ast_node_flattened
 
end module syntactic_analysis
 
program parse
  use, intrinsic :: iso_fortran_env, only: input_unit
  use, intrinsic :: iso_fortran_env, only: output_unit
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, non_intrinsic :: syntactic_analysis
 
  implicit none
 
  integer, parameter :: inp_unit_no = 100
  integer, parameter :: outp_unit_no = 101
 
  integer :: arg_count
  character(200) :: arg
  integer :: inp
  integer :: outp
 
  arg_count = command_argument_count ()
  if (3 <= arg_count) then
     call print_usage
  else
     if (arg_count == 0) then
        inp = input_unit
        outp = output_unit
     else if (arg_count == 1) then
        call get_command_argument (1, arg)
        inp = open_for_input (trim (arg))
        outp = output_unit
     else if (arg_count == 2) then
        call get_command_argument (1, arg)
        inp = open_for_input (trim (arg))
        call get_command_argument (2, arg)
        outp = open_for_output (trim (arg))
     end if
 
     block
       type(ast_t) :: ast
 
       ast = parse_token_stream (inp)
       call output_ast_flattened (outp, ast)
     end block
  end if
 
contains
 
  function open_for_input (filename) result (unit_no)
    character(*), intent(in) :: filename
    integer :: unit_no
 
    integer :: stat
 
    open (unit = inp_unit_no, file = filename, status = 'old', &
         & action = 'read', access = 'stream', form = 'unformatted',  &
         & iostat = stat)
    if (stat /= 0) then
       write (error_unit, '("Error: failed to open ", 1A, " for input")') filename
       stop 1
    end if
    unit_no = inp_unit_no
  end function open_for_input
 
  function open_for_output (filename) result (unit_no)
    character(*), intent(in) :: filename
    integer :: unit_no
 
    integer :: stat
 
    open (unit = outp_unit_no, file = filename, action = 'write', iostat = stat)
    if (stat /= 0) then
       write (error_unit, '("Error: failed to open ", 1A, " for output")') filename
       stop 1
    end if
    unit_no = outp_unit_no
  end function open_for_output
 
  subroutine print_usage
    character(200) :: progname
 
    call get_command_argument (0, progname)
    write (output_unit, '("Usage: ", 1A, " [INPUT_FILE [OUTPUT_FILE]]")') &
         &      trim (progname)
  end subroutine print_usage
 
end program parse