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

######################################################################
#
# The Rosetta Code parser in Ratfor 77.
# 
#
# Ratfor 77 is a preprocessor for FORTRAN 77; therefore we do not have
# recursive calls available. For printing the flattened tree, I use an
# ordinary non-recursive implementation of the tree traversal. The
# mutually recursive parser itself is more difficult to handle; for
# that, I implement a tiny, FORTH-like token processor that supports
# recursive calls.
#
# How to deal with input is another problem. I use formatted input,
# treating each line as a (regrettably fixed length) array of type
# CHARACTER. It is a very simple method, and leaves the input in a
# form convenient for the necessary processing (given that the input
# is not formatted in columns).
#
#
# On a POSIX platform, the program can be compiled with f2c and run
# somewhat as follows:
#
#    ratfor77 parse-in-ratfor.r > parse-in-ratfor.f
#    f2c -C -Nc40 parse-in-ratfor.f
#    cc parse-in-ratfor.c -lf2c
#    ./a.out < compiler-tests/primes.lex
#
# With gfortran, a little differently:
#
#    ratfor77 parse-in-ratfor.r > parse-in-ratfor.f
#    gfortran -fcheck=all -std=legacy parse-in-ratfor.f
#    ./a.out < compiler-tests/primes.lex
#
#
# I/O is strictly from default input and to default output, which, on
# POSIX systems, usually correspond respectively to standard input and
# standard output.
#
#---------------------------------------------------------------------
 
# Parameters that you can adjust.
 
define(LINESZ, 256)             # Size of an input line. 
define(STRNSZ, 4096)            # Size of the string pool.
define(NODSSZ, 4096)            # Size of the nodes pool.
define(DSTKSZ, 4096)            # Size of the data stack.
define(PSTKSZ, 4096)            # Size of the precedence stack.
define(XSTKSZ, 4096)            # Size of the execution stack.
 
#---------------------------------------------------------------------
 
define(TOKSZ, 5) # Size of a lexical token, in integers.
define(ILN, 1)   # Index for line number.
define(ICN, 2)   # Index for column number.
define(ITK, 3)   # Index for token number.
define(ITV, 4)   # Index for the string pool index of the token value.
define(ITN, 5)   # Index for the length of the token value.
 
define(NODESZ, 3)
define(NTAG,   1)               # Index for the tag.
                                # For an internal node --
define(NLEFT,  2)               #   Index for the left node.
define(NRIGHT, 3)               #   Index for the right node.
                                # For a leaf node --
define(NITV,   2)               #   Index for the string pool index.
define(NITN,   3)               #   Length of the value.
 
define(NIL, -1)                 # Nil node.
 
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(NDID,    0)
define(NDSTR,   1)
define(NDINT,   2)
define(NDSEQ,   3)
define(NDIF,    4)
define(NDPRTC,  5)
define(NDPRTS,  6)
define(NDPRTI,  7)
define(NDWHIL,  8)
define(NDASGN,  9)
define(NDNEG,  10)
define(NDNOT,  11)
define(NDMUL,  12)
define(NDDIV,  13)
define(NDMOD,  14)
define(NDADD,  15)
define(NDSUB,  16)
define(NDLT,   17)
define(NDLE,   18)
define(NDGT,   19)
define(NDGE,   20)
define(NDEQ,   21)
define(NDNE,   22)
define(NDAND,  23)
define(NDOR,   24)
 
subroutine string (src, isrc, nsrc, strngs, istrng, i, n)
 
  # Store a string in the string pool.
 
  implicit none
 
  character src(*)         # Source string.
  integer isrc, nsrc       # Index and length of the source substring.
  character strngs(STRNSZ) # The string pool.
  integer istrng           # The string pool's next slot.
  integer i, n             # Index and length within the string pool.
 
  integer j
 
  if (STRNSZ < istrng + nsrc)
    {
      write (*, '(''string pool exhausted'')')
      stop
    }
  for (j = 0; j < nsrc; j = j + 1)
    strngs(istrng + j) = src(isrc + j)
  i = istrng
  n = nsrc
  istrng = istrng + nsrc
end
 
subroutine astnod (node, nodes, inodes, i)
 
  # Store a node in the nodes pool.
 
  implicit none
 
  integer node(NODESZ)
  integer nodes(NODESZ, NODSSZ)
  integer inodes
  integer i
 
  integer j
 
  if (NODSSZ < inodes + 1)
    {
      write (*, '(''node pool exhausted'')')
      stop
    }
  i = inodes
  inodes = inodes + 1
  for (j = 1; j <= NODESZ; j = j + 1)
    nodes(j, i) = node(j)
end
 
function issp (c)
 
  # Is a character a space character?
 
  implicit none
 
  character c
  logical issp
 
  integer ic
 
  ic = ichar (c)
  issp = (ic == 32 || (9 <= ic && ic <= 13))
end
 
function skipsp (str, i, imax)
 
  # Skip past spaces in a string.
 
  implicit none
 
  character str(*)
  integer i
  integer imax
  integer skipsp
 
  logical issp
 
  logical done
 
  skipsp = i
  done = .false.
  while (!done)
    {
      if (imax <= skipsp)
        done = .true.
      else if (!issp (str(skipsp)))
        done = .true.
      else
        skipsp = skipsp + 1
    }
end
 
function skipns (str, i, imax)
 
  # Skip past non-spaces in a string.
 
  implicit none
 
  character str(*)
  integer i
  integer imax
  integer skipns
 
  logical issp
 
  logical done
 
  skipns = i
  done = .false.
  while (!done)
    {
      if (imax <= skipns)
        done = .true.
      else if (issp (str(skipns)))
        done = .true.
      else
        skipns = skipns + 1
    }
end
 
function trimrt (str, n)
 
  # Find the length of a string, if one ignores trailing spaces.
 
  implicit none
 
  character str(*)
  integer n
  integer trimrt
 
  logical issp
 
  logical done
 
  trimrt = n
  done = .false.
  while (!done)
    {
      if (trimrt == 0)
        done = .true.
      else if (!issp (str(trimrt)))
        done = .true.
      else
        trimrt = trimrt - 1
    }
end
 
function mktok (str, i, n)
 
  # Convert a substring to a token integer.
 
  implicit none
 
  character str(*)
  integer i
  integer n
  integer mktok
 
  character*16 tokstr(0:30)
  character*16 test
  integer j
  logical done
 
  data tokstr / '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    ' /
 
  test = '                '
  for (j = 0; j < n; j = j + 1)
    test(j + 1 : j + 1) = str(i + j)
 
  j = 0
  done = .false.
  while (!done)
    {
      if (TKEOI < j)
        {
          write (*, '(''unrecognized token'')')
          stop
        }
      else if (test == tokstr(j))
        done = .true.
      else
        j = j + 1
    }
 
  mktok = j
end
 
function mkint (str, i, n)
 
  # Convert a unsigned integer substring to an integer.
 
  implicit none
 
  character str(*)
  integer i
  integer n
  integer mkint
 
  integer j
 
  mkint = 0
  for (j = 0; j < n; j = j + 1)
    mkint = (10 * mkint) + (ichar (str(i + j)) - 48)
end
 
subroutine rdtok (strngs, istrng, blank, linno, colno, tokno, _
                  itkval, ntkval)
 
  # Read a token from the input.
 
  implicit none
 
  character strngs(STRNSZ)      # The string pool.
  integer istrng                # The string pool's next slot.
  logical blank                 # Is the line blank?
  integer linno                 # The line number.
  integer colno                 # The column number.
  integer tokno                 # The token number.
  integer itkval, ntkval        # Token value as a string.
 
  integer skipsp, skipns, trimrt
  integer mkint, mktok
 
  character line(LINESZ)
  character*20 fmt
  integer n, i, j
 
  # Read a line of text as an array of characters.
  write (fmt, '(''('', I10, ''A1)'')') LINESZ
  read (*, fmt) line
 
  n = trimrt (line, LINESZ)
  blank = (n == 0)
 
  if (!blank)
    {
      i = skipsp (line, 1, n + 1)
      j = skipns (line, i, n + 1)
      linno = mkint (line, i, j - i)
 
      i = skipsp (line, j, n + 1)
      j = skipns (line, i, n + 1)
      colno = mkint (line, i, j - i)
 
      i = skipsp (line, j, n + 1)
      j = skipns (line, i, n + 1)
      tokno = mktok (line, i, j - i)
 
      i = skipsp (line, j, n + 1)
      j = n + 1
      call string (line, i, j - i, strngs, istrng, itkval, ntkval)
    }
end
 
subroutine gettok (strngs, istrng, tok)
 
  # Get the next token.
 
  implicit none
 
  character strngs(STRNSZ)      # The string pool.
  integer istrng                # The string pool's next slot.
  integer tok(TOKSZ)
 
  integer linno, colno, tokno, itkval, ntkval
  logical blank
 
  blank = .true.
  while (blank)
    call rdtok (strngs, istrng, blank, linno, colno, tokno, _
                itkval, ntkval)
  tok(ILN) = linno
  tok(ICN) = colno
  tok(ITK) = tokno
  tok(ITV) = itkval
  tok(ITN) = ntkval
end
 
function accept (strngs, istrng, curtok, tokno)
 
  implicit none
 
  character strngs(STRNSZ)      # The string pool.
  integer istrng                # The string pool's next slot.
  integer curtok(TOKSZ)
  integer tokno
  logical accept
 
  accept = (curtok(ITK) == tokno)
  if (accept)
    call gettok (strngs, istrng, curtok)
end
 
subroutine expect (strngs, istrng, curtok, tokno)
 
  implicit none
 
  character strngs(STRNSZ)      # The string pool.
  integer istrng                # The string pool's next slot.
  integer curtok(TOKSZ)
  integer tokno
 
  logical accept
 
  if (!accept (strngs, istrng, curtok, tokno))
    {
      # This is not the same message as printed by the reference C
      # implementation. You can change that, if you wish.
      write (*, 100) curtok(ILN), curtok(ICN)
100   format ('unexpected token at line ', I5, ', column ', I5)
      stop
    }
end
 
function prec (tokno)
 
  # Precedence.
 
  implicit none
 
  integer tokno
  integer prec
 
  if (tokno == TKMUL || tokno == TKDIV || tokno == TKMOD)
    prec = 13
  else if (tokno == TKADD || tokno == TKSUB)
    prec = 12
  else if (tokno == TKNEG || tokno == TKNOT)
    prec = 14
  else if (tokno == TKLT || tokno == TKLE || _
           tokno == TKGT || tokno == TKGE)
    prec = 10
  else if (tokno == TKEQ || tokno == TKNE)
    prec = 9
  else if (tokno == TKAND)
    prec = 5
  else if (tokno == TKOR)
    prec = 4
  else
    prec = -1
end
 
function isbin (tokno)
 
  # Is an operation binary?
 
  implicit none
 
  integer tokno
  logical isbin
 
  isbin = (tokno == TKADD || _
           tokno == TKSUB || _
           tokno == TKMUL || _
           tokno == TKDIV || _
           tokno == TKMOD || _
           tokno == TKLT  || _
           tokno == TKLE  || _
           tokno == TKGT  || _
           tokno == TKGE  || _
           tokno == TKEQ  || _
           tokno == TKNE  || _
           tokno == TKAND || _
           tokno == TKOR)
end
 
function rtassc (tokno)
 
  # Is an operation right associative?
 
  implicit none
 
  integer tokno
  logical rtassc
 
  # None of the current operators is right associative.
  rtassc = .false.
end
 
function opernt (tokno)
 
  # Return the node tag for a binary operator.
 
  implicit none
 
  integer tokno
  integer opernt
 
  if (tokno == TKMUL)
    opernt = NDMUL
  else if (tokno == TKDIV)
    opernt = NDDIV
  else if (tokno == TKMOD)
    opernt = NDMOD
  else if (tokno == TKADD)
    opernt = NDADD
  else if (tokno == TKSUB)
    opernt = NDSUB
  else if (tokno == TKNEG)
    opernt = NDNEG
  else if (tokno == TKNOT)
    opernt = NDNOT
  else if (tokno == TKLT)
    opernt = NDLT
  else if (tokno == TKLE)
    opernt = NDLE
  else if (tokno == TKGT)
    opernt = NDGT
  else if (tokno == TKGE)
    opernt = NDGE
  else if (tokno == TKEQ)
    opernt = NDEQ
  else if (tokno == TKNE)
    opernt = NDNE
  else if (tokno == TKAND)
    opernt = NDAND
  else if (tokno == TKOR)
    opernt = NDOR
  else
    {
      write (*, '(''unrecognized binary operator'')')
      stop
    }
end
 
#---------------------------------------------------------------------
 
subroutine prtast (strngs, nodes, i, dstack)
 
  # Print a tree in flattened format.
 
  implicit none
 
  character strngs(*)
  integer nodes(NODESZ, NODSSZ)
  integer i
  integer dstack(DSTKSZ)
 
  integer j
  integer k
  integer n
  integer q, r
  integer tag
 
  character*80 fmt
 
  dstack(1) = i
  j = 2
  while (j != 1)
    {
      j = j - 1
      k = dstack(j)
      if (k < 1)
        write (*, '('';'')')
      else
        {
          tag = nodes(NTAG, k)
          if (tag == NDID)
            {
              n = nodes(NITN, k)
              write (fmt, '(''("Identifier ", '', I5, ''A)'')') n
              q = nodes(NITV, k)
              write (*, fmt) (strngs(r), r = q, q + n - 1)
            }
          else if (tag == NDINT)
            {
              n = nodes(NITN, k)
              write (fmt, '(''("Integer ", '', I5, ''A)'')') n
              q = nodes(NITV, k)
              write (*, fmt) (strngs(r), r = q, q + n - 1)
            }
          else if (tag == NDSTR)
            {
              n = nodes(NITN, k)
              write (fmt, '(''("String ", '', I5, ''A)'')') n
              q = nodes(NITV, k)
              write (*, fmt) (strngs(r), r = q, q + n - 1)
            }
          else
            {
              if (tag == NDSEQ)
                write (*, '(''Sequence'')')
              else if (tag == NDIF)
                write (*, '(''If'')')
              else if (tag == NDPRTC)
                write (*, '(''Prtc'')')
              else if (tag == NDPRTS)
                write (*, '(''Prts'')')
              else if (tag == NDPRTI)
                write (*, '(''Prti'')')
              else if (tag == NDWHIL)
                write (*, '(''While'')')
              else if (tag == NDASGN)
                write (*, '(''Assign'')')
              else if (tag == NDNEG)
                write (*, '(''Negate'')')
              else if (tag == NDNOT)
                write (*, '(''Not'')')
              else if (tag == NDMUL)
                write (*, '(''Multiply'')')
              else if (tag == NDDIV)
                write (*, '(''Divide'')')
              else if (tag == NDMOD)
                write (*, '(''Mod'')')
              else if (tag == NDADD)
                write (*, '(''Add'')')
              else if (tag == NDSUB)
                write (*, '(''Subtract'')')
              else if (tag == NDLT)
                write (*, '(''Less'')')
              else if (tag == NDLE)
                write (*, '(''LessEqual'')')
              else if (tag == NDGT)
                write (*, '(''Greater'')')
              else if (tag == NDGE)
                write (*, '(''GreaterEqual'')')
              else if (tag == NDEQ)
                write (*, '(''Equal'')')
              else if (tag == NDNE)
                write (*, '(''NotEqual'')')
              else if (tag == NDAND)
                write (*, '(''And'')')
              else if (tag == NDOR)
                write (*, '(''Or'')')
              else
                {
                  write (*, '(''unrecognized node type'')')
                  stop
                }
              if (DSTKSZ - 2 < n)
                {
                  write (*, '(''node stack overflow'')')
                  stop
                }
              dstack(j) = nodes(NRIGHT, k)
              dstack(j + 1) = nodes(NLEFT, k)
              j = j + 2
            }
        }
    }
end
 
#---------------------------------------------------------------------
 
# A tiny recursive language. Each instruction is two integers,
# although the second integer may be XPAD. XLOCs are named by
# integers.
 
define(XPAD,     0)             # "Padding"
 
define(XLOC,    10)             # "Jump or call location"
define(XJUMP,   20)             # "Jump to a place"
define(XJUMPT,  30)             # "Jump to a place, if true"
define(XJUMPF,  40)             # "Jump to a place, if false"
define(XCALL,   50)             # "Call a subprogram"
define(XRET,    60)             # "Return from a subprogram"
 
define(XPUSH,  110)             # "Push an immediate value"
define(XSWAP,  120)             # "Swap top two stack entries"
 
define(XLT,    200)             # "Less than?"
define(XADDI,  210)             # "Add immediate."
 
define(XPPUSH, 610)             # "Push top to precedence stack"
define(XPCOPY, 620)             # "Copy top of prec stack to top"
define(XPDROP, 630)             # "Drop top of precedence stack"
 
define(XGETTK, 710)             # "Get the next token"
define(XTOKEQ, 720)             # "Token equals the argument?"
define(XEXPCT, 730)             # "Expect token"
define(XACCPT, 740)             # "Accept token"
 
define(XTOK,   810)             # "Push the token number"
define(XBINOP, 820)             # "Is top a binary operator?"
define(XRASSC, 830)             # "Is top a right associative op?"
define(XPREC,  840)             # "Precedence of token no. on top"
define(XOPER,  850)             # "Operator for token no. on top"
 
define(XINTND, 970)             # "Make internal node"
define(XOPND,  975)             # "Make internal node for operator"
define(XLEFND, 980)             # "Make leaf node"
define(XNILND, 985)             # "Make nil node"
 
define(XERROR, 1010)            # "Error"
define(XRWARN, 1020)            # "Unused right associative branch"
 
define(XPING,  2010)    # Print a ping message (for debugging)
define(XPRTND, 2020)    # Print node at stack top (for debugging)
define(XPRTTP, 2030)    # Print stack top as integer (for debugging)
define(XPRTTK, 2040)    # Print the current token (for debugging)
define(XPRTP,  2050)    # Print the current precedence (for debugging)
define(XPRTST, 2060)    # Print the whole data stack (for debugging)
 
# Call and jump locations in our program:
define(CSTMT,  1000)            # stmt
define(STMT01, 1010)
define(STMT02, 1020)
define(STMT03, 1030)
define(STMT04, 1040)
define(STMT05, 1050)
define(STMT06, 1060)
define(STMT07, 1070)
define(STMT08, 1080)
define(STMT09, 1090)
define(STMT10, 1100)
define(STMT11, 1110)
define(STMT12, 1120)
define(STMT13, 1130)
define(STMT14, 1140)
define(STMT15, 1150)
define(CPEXPR, 2000)            # paren_expr
define(CEXPR,  3000)            # expr
define(EXPR01, 3010)
define(EXPR02, 3020)
define(EXPR03, 3030)
define(EXPR04, 3040)
define(EXPR05, 3050)
define(EXPR06, 3060)
define(EXPR10, 3100)
define(EXPR11, 3110)
define(EXPR12, 3120)
define(EXPR13, 3130)
define(PARS01, 4010)            # parse
 
# Error numbers.
define(EXSTMT, 100)             # "expecting start of statement"
define(EXPRIM, 200)             # "expecting a primary"
 
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
subroutine ld(code, i, instr1, instr2)
 
  implicit none
 
  integer code(*)
  integer i
  integer instr1, instr2
 
  code(i) = instr1
  code(i + 1) = instr2
  i = i + 2
end
 
subroutine ldcode (code)
 
  # Load the code that is in the recursive language. The array
  # allocated to hold the code must be large enough, but we do not
  # check.
 
  implicit none
 
  integer code(*)
  integer i
 
  i = 1
 
  #--------------------------------------------------
 
  # The main loop.
  call ld (code, i, XNILND, XPAD) # Nil node for start of sequence.
  call ld (code, i, XGETTK, XPAD)
  call ld (code, i, XLOC, PARS01) # Top of loop
  call ld (code, i, XCALL, CSTMT)
  call ld (code, i, XINTND, NDSEQ)
  call ld (code, i, XTOKEQ, TKEOI) # End_of_input
  call ld (code, i, XJUMPF, PARS01) # Loop unless end of input.
  call ld (code, i, XRET, XPAD)
 
  #--------------------------------------------------
 
  call ld (code, i, XLOC, CEXPR)  # Start of "expr"
  call ld (code, i, XPPUSH, XPAD) # Push the precedence argument.
 
  call ld (code, i, XTOKEQ, TKLPAR) # LeftParen
  call ld (code, i, XJUMPF, EXPR01)
 
  # "( ... )"
  call ld (code, i, XCALL, CPEXPR)
  call ld (code, i, XJUMP, EXPR10)
 
  call ld (code, i, XLOC, EXPR01)
 
  call ld (code, i, XACCPT, TKSUB) # Op_subtract
  call ld (code, i, XJUMPF, EXPR02)
 
  # Unary minus
  call ld (code, i, XPUSH, TKNEG)
  call ld (code, i, XPREC, XPAD)
  call ld (code, i, XCALL, CEXPR)  # expr <--
  call ld (code, i, XNILND, XPAD)  # expr nil <--
  call ld (code, i, XINTND, NDNEG)
  call ld (code, i, XJUMP, EXPR10)
 
  call ld (code, i, XLOC, EXPR02)
 
  call ld (code, i, XACCPT, TKADD) # Op_add
  call ld (code, i, XJUMPF, EXPR03)
 
  # Unary plus
  call ld (code, i, XPUSH, TKNEG)
  call ld (code, i, XPREC, XPAD)
  call ld (code, i, XCALL, CEXPR)  # expr <--
  call ld (code, i, XJUMP, EXPR10)
 
  call ld (code, i, XLOC, EXPR03)
 
  call ld (code, i, XACCPT, TKNOT) # Op_not
  call ld (code, i, XJUMPF, EXPR04)
 
  # "!"
  call ld (code, i, XPUSH, TKNOT)
  call ld (code, i, XPREC, XPAD)
  call ld (code, i, XCALL, CEXPR)  # expr <--
  call ld (code, i, XNILND, XPAD)  # expr nil <--
  call ld (code, i, XINTND, NDNOT)
  call ld (code, i, XJUMP, EXPR10)
 
  call ld (code, i, XLOC, EXPR04)
 
  call ld (code, i, XTOKEQ, TKID) # Identifier
  call ld (code, i, XJUMPF, EXPR05)
 
  # Identifier
  call ld (code, i, XLEFND, NDID)
  call ld (code, i, XGETTK, XPAD)
  call ld (code, i, XJUMP, EXPR10)
 
  call ld (code, i, XLOC, EXPR05)
 
  call ld (code, i, XTOKEQ, TKINT) # Integer
  call ld (code, i, XJUMPF, EXPR06)
 
  # Integer.
  call ld (code, i, XLEFND, NDINT)
  call ld (code, i, XGETTK, XPAD)
  call ld (code, i, XJUMP, EXPR10)
 
  call ld (code, i, XLOC, EXPR06)
 
  call ld (code, i, XERROR, EXPRIM)
 
  call ld (code, i, XLOC, EXPR10) # Top of precedence climbing loop
 
  call ld (code, i, XTOK, XPAD)
  call ld (code, i, XBINOP, XPAD)
  call ld (code, i, XJUMPF, EXPR11) # Exit loop, if not a binary op.
 
  call ld (code, i, XTOK, XPAD)
  call ld (code, i, XPREC, XPAD)    # curtok_prec <--
  call ld (code, i, XPCOPY, XPAD)   # curtok_prec p <--
  call ld (code, i, XLT, XPAD)      # (curtok_prec < p)? <--
  call ld (code, i, XJUMPT, EXPR11) # Exit loop if true.
 
  call ld (code, i, XTOK, XPAD)
  call ld (code, i, XOPER, XPAD) # x op <--
  call ld (code, i, XSWAP, XPAD) # op x <--
 
  call ld (code, i, XTOK, XPAD)
  call ld (code, i, XRASSC, XPAD)
  call ld (code, i, XJUMPT, EXPR12)
 
  # Left associative.
  call ld (code, i, XTOK, XPAD)
  call ld (code, i, XPREC, XPAD)
  call ld (code, i, XADDI, 1)   # op x q:=(q + 1) <--
  call ld (code, i, XJUMP, EXPR13)
 
  call ld (code, i, XLOC, EXPR12)
 
  # Right associative. (Currently an unused branch.)
  call ld (code, i, XRWARN, XPAD) # Warn about unused branch.
  call ld (code, i, XTOK, XPAD)
  call ld (code, i, XPREC, XPAD) # op x q <--
 
  call ld (code, i, XLOC, EXPR13)
 
  call ld (code, i, XGETTK, XPAD)
  call ld (code, i, XCALL, CEXPR) # op x expr(q) <--
  call ld (code, i, XOPND, XPAD)  # new_x <--
 
  call ld (code, i, XJUMP, EXPR10) # Continue looping.
 
  call ld (code, i, XLOC, EXPR11) # Loop exit.
 
  call ld (code, i, XPDROP, XPAD) # Drop the precedence argument.
  call ld (code, i, XRET, XPAD)   # End of "expr"
 
  #--------------------------------------------------
 
  call ld (code, i, XLOC, CPEXPR) # Start of "paren_expr"
  call ld (code, i, XEXPCT, TKLPAR)
  call ld (code, i, XPUSH, 0)
  call ld (code, i, XCALL, CEXPR)
  call ld (code, i, XEXPCT, TKRPAR)
  call ld (code, i, XRET, XPAD)
 
  #--------------------------------------------------
 
  call ld (code, i, XLOC, CSTMT)  # Start of "stmt"
 
  call ld (code, i, XACCPT, TKIF) # Keyword_if
  call ld (code, i, XJUMPF, STMT01)
 
  # "if (...) then ... else ..."
  call ld (code, i, XCALL, CPEXPR)  # Get the paren expr ("if (...)").
  call ld (code, i, XCALL, CSTMT)   # Get the "then" clause.
  call ld (code, i, XACCPT, TKELSE) # Keyword_else
  call ld (code, i, XJUMPF, STMT02)
  call ld (code, i, XCALL, CSTMT) # Get the "else" clause.
  call ld (code, i, XJUMP, STMT03)
  call ld (code, i, XLOC, STMT02)
  call ld (code, i, XNILND, XPAD) # The "else" statement is nil.
  call ld (code, i, XLOC, STMT03)
  call ld (code, i, XINTND, NDIF) # ("If" pred ("If" then else))
  call ld (code, i, XINTND, NDIF)
  call ld (code, i, XRET, XPAD)
 
  call ld (code, i, XLOC, STMT01)
 
  call ld (code, i, XACCPT, TKPUTC) # Keyword_putc
  call ld (code, i, XJUMPF, STMT04)
 
  # "putc (...);"
  call ld (code, i, XCALL, CPEXPR) # Get the paren expr.
  call ld (code, i, XNILND, XPAD)
  call ld (code, i, XINTND, NDPRTC) # ("Prtc" expr nil)
  call ld (code, i, XEXPCT, TKSEMI) # Expect ";"
  call ld (code, i, XRET, XPAD)
 
  call ld (code, i, XLOC, STMT04)
 
  call ld (code, i, XACCPT, TKPRNT) # Keyword_print
  call ld (code, i, XJUMPF, STMT05)
 
  # "print(... , ... , ...);"
  call ld (code, i, XEXPCT, TKLPAR) # Expect "("
  call ld (code, i, XNILND, XPAD)   # nil for start of sequence
  call ld (code, i, XLOC, STMT08)   # Top of loop
  call ld (code, i, XTOKEQ, TKSTR)
  call ld (code, i, XJUMPT, STMT06)
  call ld (code, i, XPUSH, 0)
  call ld (code, i, XCALL, CEXPR)
  call ld (code, i, XNILND, XPAD)
  call ld (code, i, XINTND, NDPRTI) # ("Prti" expr nil)
  call ld (code, i, XJUMP, STMT07)
  call ld (code, i, XLOC, STMT06)
  call ld (code, i, XLEFND, NDSTR)
  call ld (code, i, XNILND, XPAD)
  call ld (code, i, XINTND, NDPRTS) # ("Prts" ("String" ...) nil)
  call ld (code, i, XGETTK, XPAD)
  call ld (code, i, XLOC, STMT07)
  call ld (code, i, XINTND, NDSEQ)  # ("Sequence" ... ...)
  call ld (code, i, XACCPT, TKCMMA) # Comma
  call ld (code, i, XJUMPT, STMT08) # Loop if comma.
  call ld (code, i, XEXPCT, TKRPAR) # Expect ")"
  call ld (code, i, XEXPCT, TKSEMI) # Expect ";"
  call ld (code, i, XRET, XPAD)
 
  call ld (code, i, XLOC, STMT05)
 
  call ld (code, i, XACCPT, TKSEMI) # Semicolon
  call ld (code, i, XJUMPF, STMT09)
 
  # Accept a lone ";".
  call ld (code, i, XRET, XPAD)
 
  call ld (code, i, XLOC, STMT09)
 
  call ld (code, i, XTOKEQ, TKID) # Identifier
  call ld (code, i, XJUMPF, STMT10)
 
  # "identifier = expr;"
  call ld (code, i, XLEFND, NDID) # ("Identifier" ...)
  call ld (code, i, XGETTK, XPAD)
  call ld (code, i, XEXPCT, TKASGN)
  call ld (code, i, XPUSH, 0)
  call ld (code, i, XCALL, CEXPR)
  call ld (code, i, XINTND, NDASGN) # ("Assign" ("Identifier" ...) expr)
  call ld (code, i, XEXPCT, TKSEMI)
  call ld (code, i, XRET, XPAD)
 
  call ld (code, i, XLOC, STMT10)
 
  call ld (code, i, XACCPT, TKWHIL) # While
  call ld (code, i, XJUMPF, STMT11)
 
  # "while (...) ..."
  call ld (code, i, XCALL, CPEXPR)
  call ld (code, i, XCALL, CSTMT)
  call ld (code, i, XINTND, NDWHIL) # ("While" pred stmt)
  call ld (code, i, XRET, XPAD)
 
  call ld (code, i, XLOC, STMT11)
 
  call ld (code, i, XACCPT, TKLBRC) # LeftBrace
  call ld (code, i, XJUMPF, STMT12)
 
  # "{ ... }"
  call ld (code, i, XNILND, XPAD)   # nil for start of sequence
  call ld (code, i, XLOC, STMT13)   # Top of loop
  call ld (code, i, XTOKEQ, TKEOI)
  call ld (code, i, XJUMPT, STMT14)
  call ld (code, i, XTOKEQ, TKRBRC)
  call ld (code, i, XJUMPT, STMT14)
  call ld (code, i, XCALL, CSTMT)
  call ld (code, i, XINTND, NDSEQ)  # ("Sequence" ... ...)
  call ld (code, i, XJUMP, STMT13)  # Loop again.
  call ld (code, i, XLOC, STMT14)   # Loop exit
  call ld (code, i, XEXPCT, TKRBRC) # Expect ";".
  call ld (code, i, XRET, XPAD)
 
  call ld (code, i, XLOC, STMT12)
 
  call ld (code, i, XTOKEQ, TKEOI) # End_of_input
  call ld (code, i, XJUMPF, STMT15)
 
  call ld (code, i, XRET, XPAD)
 
  call ld (code, i, XLOC, STMT15)
 
  call ld (code, i, XERROR, EXSTMT) # "expecting start of stmt"
 
  #--------------------------------------------------
 
end
 
subroutine dtpush (dstack, idstck, x)
 
  # Push to the data stack.
 
  implicit none
 
  integer dstack(DSTKSZ)
  integer idstck
  integer x
 
  if (DSTKSZ < idstck)
    {
      write (*, '(''node stack exhausted'')')
      stop
    }
  dstack(idstck) = x
  idstck = idstck + 1
end
 
function dtpop (dstack, idstck)
 
  # Pop from the data stack.
 
  implicit none
 
  integer dstack(DSTKSZ)
  integer idstck
  integer dtpop
 
  if (DSTKSZ < idstck)
    {
      write (*, '(''node stack exhausted'')')
      stop
    }
  idstck = idstck - 1
  dtpop = dstack(idstck)
end
 
subroutine ppush (pstack, ipstck, x)
 
  # Push to the precedence stack.
 
  implicit none
 
  integer pstack(PSTKSZ)
  integer ipstck
  integer x
 
  if (PSTKSZ < ipstck)
    {
      write (*, '(''precedence stack exhausted'')')
      stop
    }
  pstack(ipstck) = x
  ipstck = ipstck + 1
end
 
function ppop (pstack, ipstck)
 
  # Pop from the precedence stack.
 
  implicit none
 
  integer pstack(PSTKSZ)
  integer ipstck
  integer ppop
 
  if (PSTKSZ < ipstck)
    {
      write (*, '(''precedence stack exhausted'')')
      stop
    }
  ipstck = ipstck - 1
  ppop = pstack(ipstck)
end
 
function ipfind (code, loc)
 
  # Find a location.
 
  implicit none
 
  integer code(*)
  integer loc
  integer ipfind
 
  integer i
 
  i = 1
  while (code(i) != XLOC || code(i + 1) != loc)
    i = i + 2
  ipfind = i
end
 
subroutine ippush (xstack, ixstck, ip)
 
  # Push the instruction pointer.
 
  implicit none
 
  integer xstack(XSTKSZ)
  integer ixstck
  integer ip
 
  if (XSTKSZ < ixstck)
    {
      write (*, '(''recursive call stack exhausted'')')
      stop
    }
  xstack(ixstck) = ip
  ixstck = ixstck + 1
end
 
function ippop (xstack, ixstck)
 
  # Pop an instruction pointer value.
 
  implicit none
 
  integer xstack(XSTKSZ)
  integer ixstck
  integer ippop
 
  if (ixstck == 1)
    {
      write (*, '(''recursive call stack underflow'')')
      stop
    }
  ixstck = ixstck - 1
  ippop = xstack(ixstck)
end
 
function logl2i (u)
 
  # Convert LOGICAL to INTEGER.
 
  implicit none
 
  logical u
  integer logl2i
 
  if (u)
    logl2i = 1
  else
    logl2i = 0
end
 
subroutine recurs (strngs, istrng,
                   nodes, inodes, _
                   dstack, idstck, _
                   pstack, ipstck, _
                   xstack, ixstck, _
                   code, ip)
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  integer nodes(NODESZ, NODSSZ) # Node pool
  integer inodes                # Node pool's next slot.
  integer dstack(DSTKSZ)        # Data stack.
  integer idstck                # Data stack pointer.
  integer pstack(PSTKSZ)        # Precedence stack.
  integer ipstck                # Precedence stack pointer.
  integer xstack(XSTKSZ)        # Execution stack.
  integer ixstck                # Execution stack pointer.
  integer code(*)               # Code in the recursive language.
  integer ip                    # Instruction pointer.
 
  integer prec
  integer opernt
  integer logl2i
  integer dtpop
  integer ppop
  integer ippop
  integer ipfind
  logical accept
  logical isbin
  logical rtassc
 
  integer curtok(TOKSZ)
  integer node(NODESZ)
  integer curprc                # Current precedence value.
  integer i, j
  logical done
 
  curprc = 0
  done = .false.
  while (.not. done)
    {
      if (code(ip) == XLOC)
        {
          ip = ip + 2
        }
      else if (code(ip) == XJUMP)
        {
          ip = ipfind (code, code(ip + 1))
        }
      else if (code(ip) == XJUMPT)
        {
          i = dtpop (dstack, idstck)
          if (i != 0)
            ip = ipfind (code, code(ip + 1))
          else
            ip = ip + 2
        }
      else if (code(ip) == XJUMPF)
        {
          i = dtpop (dstack, idstck)
          if (i == 0)
            ip = ipfind (code, code(ip + 1))
          else
            ip = ip + 2
        }
      else if (code(ip) == XCALL)
        {
          call ippush (xstack, ixstck, ip + 2)
          ip = ipfind (code, code(ip + 1))
        }
      else if (code(ip) == XRET)
        {
          if (ixstck == 1)
            done = .true.
          else
            ip = ippop (xstack, ixstck)
        }
      else if (code(ip) == XINTND)
        {
          node(NRIGHT) = dtpop (dstack, idstck)
          node(NLEFT) = dtpop (dstack, idstck)
          node(NTAG) = code(ip + 1)
          call astnod (node, nodes, inodes, i)
          call dtpush (dstack, idstck, i)
          ip = ip + 2
        }
      else if (code(ip) == XOPND)
        {
          node(NRIGHT) = dtpop (dstack, idstck)
          node(NLEFT) = dtpop (dstack, idstck)
          node(NTAG) = dtpop (dstack, idstck)
          call astnod (node, nodes, inodes, i)
          call dtpush (dstack, idstck, i)
          ip = ip + 2
        }
      else if (code(ip) == XLEFND)
        {
          node(NITV) = curtok(ITV)
          node(NITN) = curtok(ITN)
          node(NTAG) = code(ip + 1)
          call astnod (node, nodes, inodes, i)
          call dtpush (dstack, idstck, i)
          ip = ip + 2
        }
      else if (code(ip) == XNILND)
        {
          call dtpush (dstack, idstck, NIL)
          ip = ip + 2
        }
      else if (code(ip) == XGETTK)
        {
          call gettok (strngs, istrng, curtok)
          ip = ip + 2
        }
      else if (code(ip) == XTOKEQ)
        {
          i = logl2i (curtok(ITK) == code(ip + 1))
          call dtpush (dstack, idstck, i)
          ip = ip + 2
        }
      else if (code(ip) == XEXPCT)
        {
          call expect (strngs, istrng, curtok, code(ip + 1))
          ip = ip + 2
        }
      else if (code(ip) == XACCPT)
        {
          i = logl2i (accept (strngs, istrng, curtok, code(ip + 1)))
          call dtpush (dstack, idstck, i)
          ip = ip + 2
        }
      else if (code(ip) == XSWAP)
        {
          i = dtpop (dstack, idstck)
          j = dtpop (dstack, idstck)
          call dtpush (dstack, idstck, i)
          call dtpush (dstack, idstck, j)
          ip = ip + 2
        }
      else if (code(ip) == XLT)
        {
          j = dtpop (dstack, idstck)
          i = dtpop (dstack, idstck)
          call dtpush (dstack, idstck, logl2i (i < j))
          ip = ip + 2
        }
      else if (code(ip) == XADDI)
        {
          i = dtpop (dstack, idstck)
          call dtpush (dstack, idstck, i + code(ip + 1))
          ip = ip + 2
        }
      else if (code(ip) == XPPUSH)
        {
          i = dtpop (dstack, idstck)
          call ppush (pstack, ipstck, i)
          ip = ip + 2
        }
      else if (code(ip) == XPCOPY)
        {
          i = ppop (pstack, ipstck)
          call ppush (pstack, ipstck, i)
          call dtpush (dstack, idstck, i)
          ip = ip + 2
        }
      else if (code(ip) == XPDROP)
        {
          i = ppop (pstack, ipstck)
          ip = ip + 2
        }
      else if (code(ip) == XBINOP)
        {
          i = dtpop (dstack, idstck)
          i = logl2i (isbin (i))
          call dtpush (dstack, idstck, i)
          ip = ip + 2
        }
      else if (code(ip) == XRASSC)
        {
          i = dtpop (dstack, idstck)
          i = logl2i (rtassc (i))
          call dtpush (dstack, idstck, i)
          ip = ip + 2
        }
      else if (code(ip) == XPREC)
        {
          i = dtpop (dstack, idstck)
          call dtpush (dstack, idstck, prec (i))
          ip = ip + 2
        }
      else if (code(ip) == XOPER)
        {
          i = dtpop (dstack, idstck)
          call dtpush (dstack, idstck, opernt (i))
          ip = ip + 2
        }
      else if (code(ip) == XTOK)
        {
          call dtpush (dstack, idstck, curtok(ITK))
          ip = ip + 2
        }
      else if (code(ip) == XPUSH)
        {
          call dtpush (dstack, idstck, code(ip + 1))
          ip = ip + 2
        }
      else if (code(ip) == XERROR)
        {
          if (code(ip + 1) == EXSTMT)
            {
              write (*, 1000) curtok(ILN), curtok(ICN)
1000          format ('expected start of statement at line ', _
                      I5, ', column ', I5)
            }
          else if (code(ip + 1) == EXPRIM)
            {
              write (*, 1010) curtok(ILN), curtok(ICN)
1010          format ('expected a primary at line ', _
                      I5, ', column ', I5)
            }
          else
            {
              write (*, 2000) curtok(ILN), curtok(ICN)
2000          format ('syntax error at line ', _
                      I5, ', column ', I5)
            }
          stop
        }
      else if (code(ip) == XRWARN)
        {
          write (*, 3000)
3000      format ('executing supposedly unused ', _
                  '"right associative" operator branch')
          ip = ip + 2
        }
      else if (code(ip) == XPING)
        {
          write (*, '(''ping'')')
          ip = ip + 2
        }
      else if (code(ip) == XPRTND)
        {
          i = dtpop (dstack, idstck)
          call dtpush (dstack, idstck, i)
          call prtast (strngs, nodes, i, dstack)
          ip = ip + 2
        }
      else if (code(ip) == XPRTTP)
        {
          i = dtpop (dstack, idstck)
          call dtpush (dstack, idstck, i)
          write (*, '(''top = '', I20)') i
          ip = ip + 2
        }
      else if (code(ip) == XPRTTK)
        {
          write (*, '(''curtok ='', 5(1X, I5))') curtok
          ip = ip + 2
        }
      else if (code(ip) == XPRTP)
        {
          write (*, '(''curprc = '', I2)') curprc
          ip = ip + 2
        }
      else if (code(ip) == XPRTST)
        {
          write (*, '(''dstack ='', 100000(1X, I5))') _
                (dstack(i), i = 1, idstck - 1)
          ip = ip + 2
        }
      else
        {
          write (*, '(''illegal instruction'')')
          stop
        }
    }
end
 
#---------------------------------------------------------------------
 
program parse
 
  implicit none
 
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  integer nodes(NODESZ, NODSSZ) # Node pool
  integer inodes                # Node pool's next slot.
  integer dstack(DSTKSZ)        # Node stack.
  integer idstck                # Node stack pointer.
  integer pstack(PSTKSZ)        # Precedence stack.
  integer ipstck                # Precedence stack pointer.
  integer xstack(XSTKSZ)        # Execution stack.
  integer ixstck                # Execution stack pointer.
  integer code(1000)            # Recursive code.
  integer ip                    # Instruction pointer.
 
  integer i
 
  integer dtpop
 
  istrng = 1
  inodes = 1
  idstck = 1
  ipstck = 1
  ixstck = 1
 
  call ldcode (code)
  ip = 1
 
  call recurs (strngs, istrng, nodes, inodes, _
               dstack, idstck, pstack, ipstck, _
               xstack, ixstck, code, ip)
  i = dtpop (dstack, idstck)
  call prtast (strngs, nodes, i, dstack)
end
 
######################################################################