Compiler/AST interpreter

From Rosetta Code
< Compiler(Redirected from AST interpreter)
Task
Compiler/AST interpreter
You are encouraged to solve this task according to the task description, using any language you may know.
AST interpreter

An AST interpreter interprets an Abstract Syntax Tree (AST) produced by a Syntax Analyzer.

Take the AST output from the Syntax analyzer task, and interpret it as appropriate. Refer to the Syntax analyzer task for details of the AST.

Loading the AST from the syntax analyzer is as simple as (pseudo code)
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)
The interpreter algorithm is relatively simple
interp(x)
    if x == NULL return NULL
    elif x.node_type == Integer return x.value converted to an integer
    elif x.node_type == Ident   return the current value of variable x.value
    elif x.node_type == String  return x.value
    elif x.node_type == Assign
                    globals[x.left.value] = interp(x.right)
                    return NULL
    elif x.node_type is a binary operator return interp(x.left) operator interp(x.right)
    elif x.node_type is a unary operator, return return operator interp(x.left)
    elif x.node_type ==  If
                    if (interp(x.left)) then interp(x.right.left)
                    else interp(x.right.right)
                    return NULL
    elif x.node_type == While
                    while (interp(x.left)) do interp(x.right)
                    return NULL
    elif x.node_type == Prtc
                    print interp(x.left) as a character, no newline
                    return NULL
    elif x.node_type == Prti
                    print interp(x.left) as an integer, no newline
                    return NULL
    elif x.node_type == Prts
                    print interp(x.left) as a string, respecting newlines ("\n")
                    return NULL
    elif x.node_type == Sequence
                    interp(x.left)
                    interp(x.right)
                    return NULL
    else
        error("unknown node type")

Notes:

Because of the simple nature of our tiny language, Semantic analysis is not needed.

Your interpreter should use C like division semantics, for both division and modulus. For division of positive operands, only the non-fractional portion of the result should be returned. In other words, the result should be truncated towards 0.

This means, for instance, that 3 / 2 should result in 1.

For division when one of the operands is negative, the result should be truncated towards 0.

This means, for instance, that 3 / -2 should result in -1.

Test program
prime.t parse | interp
/*
 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");
3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26
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

ALGOL W[edit]

begin % AST interpreter %
    % parse tree nodes %
    record node( integer         type
               ; reference(node) left, right
               ; integer         iValue % nString/nIndentifier number or nInteger value %
               );
    integer     nIdentifier, nString, nInteger, nSequence, nIf,   nPrtc, nPrts
          ,     nPrti,       nWhile,  nAssign,  nNegate,   nNot,  nMultiply
          ,     nDivide,     nMod,    nAdd,     nSubtract, nLess, nLessEqual
          ,     nGreater,    nGreaterEqual,     nEqual,    nNotEqual,    nAnd, nOr
          ;
    string(14) array ndName ( 1 :: 25 );
    integer    MAX_NODE_TYPE;
    % string literals and identifiers - uses a linked list - a hash table might be better... %
    string(1)   array text ( 0 :: 4095 );
    integer     textNext, TEXT_MAX;
    record textElement ( integer start, length; reference(textElement) next );
    reference(textElement) idList, stList;
    % memory - identifiers hold indexes to locations here %
    integer array data ( 1 :: 4096 );

    % returns a new node with left and right branches %
    reference(node) procedure opNode ( integer value opType; reference(node) value opLeft, opRight ) ; begin
        node( opType, opLeft, opRight, 0 )
    end opNode ;

    % returns a new operand node %
    reference(node) procedure operandNode ( integer value opType, opValue ) ; begin
        node( opType, null, null, opValue )
    end operandNode ;

    % reports an error and stops %
    procedure rtError( string(80) value message ); begin
        integer errorPos;
        write( s_w := 0, "**** Runtime error " );
        errorPos := 0;
        while errorPos < 80 and message( errorPos // 1 ) not = "." do begin
            writeon( s_w := 0, message( errorPos // 1 ) );
            errorPos := errorPos + 1
        end while_not_at_end_of_message ;
        writeon( s_w := 0, "." );
        assert( false )
    end rtError ;

    % reads a node from standard input %
    reference(node) procedure readNode ; begin
        reference(node) resultNode;

        % parses a string from line and stores it in a string in the text array %
        % - if it is not already present in the specified textElement list.     %
        % returns the position of the string in the text array                  %
        integer procedure readString ( reference(textElement) value result txList; string(1) value terminator ) ; begin
            string(256) str;
            integer     sLen, sPos, ePos;
            logical     found;
            reference(textElement) txPos, txLastPos;
            % get the text of the string %
            str  := " ";
            sLen := 0;
            str( sLen // 1 ) := line( lPos // 1 );
            sLen := sLen + 1;
            lPos := lPos + 1;
            while lPos <= 255 and line( lPos // 1 ) not = terminator do begin
                str( sLen // 1 ) := line( lPos // 1 );
                sLen := sLen + 1;
                lPos := lPos + 1
            end while_more_string ;
            if lPos > 255 then rtError( "Unterminated String in node file." );
            % attempt to find the text in the list of strings/identifiers %
            txLastPos := txPos := txList;
            found := false;
            ePos := 0;
            while not found and txPos not = null do begin
                ePos  := ePos + 1;
                found := ( length(txPos) = sLen );
                sPos  := 0;
                while found and sPos < sLen do begin
                    found := str( sPos // 1 ) = text( start(txPos) + sPos );
                    sPos  := sPos + 1
                end while_not_found ;
                txLastPos := txPos;
                if not found then txPos := next(txPos)
            end while_string_not_found ;
            if not found then begin
                % the string/identifier is not in the list - add it %
                ePos := ePos + 1;
                if txList = null then txList := textElement( textNext, sLen, null )
                                 else next(txLastPos) := textElement( textNext, sLen, null );
                if textNext + sLen > TEXT_MAX then rtError( "Text space exhausted." )
                else begin
                    for cPos := 0 until sLen - 1 do begin
                        text( textNext ) := str( cPos // 1 );
                        textNext := textNext + 1
                    end for_cPos
                end
            end if_not_found ;
            ePos
        end readString ;

        % gets an integer from the line - no checks for valid digits %
        integer procedure readInteger ; begin
            integer n;
            n := 0;
            while line( lPos // 1 ) not = " " do begin
                n    := ( n * 10 ) + ( decode( line( lPos // 1 ) ) - decode( "0" ) );
                lPos := lPos + 1
            end while_not_end_of_integer ;
            n
        end readInteger ;

        string(256) line;
        string(16)  name;
        integer     lPos, tPos, ndType;
        tPos := lPos := 0;
        readcard( line );
        % get the node type name %
        while line( lPos // 1 ) = " " do lPos := lPos + 1;
        name := "";
        while lPos < 256 and line( lPos // 1 ) not = " " do begin
            name( tPos // 1 ) := line( lPos // 1 );
            lPos := lPos + 1;
            tPos := tPos + 1
        end  while_more_name ;
        % determine the node type %
        ndType         := 1;
        resultNode     := null;
        if name not = ";" then begin
            % not a null node %
            while ndType <= MAX_NODE_TYPE and name not = ndName( ndType ) do ndType := ndType + 1;
            if ndType > MAX_NODE_TYPE then rtError( "Malformed node." );
            % handle the additional parameter for identifier/string/integer, or sub-nodes for operator nodes %
            if ndType = nInteger or ndType = nIdentifier or ndType = nString then begin
                while line( lPos // 1 ) = " " do lPos := lPos + 1;
                if      ndType = nInteger    then resultNode := operandNode( ndType, readInteger )
                else if ndType = nIdentifier then resultNode := operandNode( ndType, readString( idList, " "  ) )
                else  % ndType = nString     %    resultNode := operandNode( ndType, readString( stList, """" ) )
                end
            else begin
                % operator node %
                reference(node) leftNode;
                leftNode   := readNode;
                resultNode := opNode( ndType, leftNode, readNode )
            end
        end if_non_null_node ;
        resultNode
    end readNode ;

    % interprets the specified node and returns the value %
    integer procedure eval ( reference(node) value n ) ; begin
        integer v;

        % prints a string from text, escape sequences are interpreted %
        procedure writeOnText( reference(textElement) value txHead; integer value txNumber ) ;
        begin
            reference(textElement) txPos;
            integer                count;
            txPos := txHead;
            count := 1;
            while count < txNumber and txPos not = null do begin
                txPos := next(txPos);
                count := count + 1
            end while_text_element_not_found ;
            if txPos = null then rtError( "INTERNAL ERROR: text not found." )
            else begin
                % found the text - output it, handling escape sequences %
                integer cPos;
                cPos := 1; % start from 1 to skip over the leading " %
                while cPos < length(txPos) do begin
                    string(1) ch;
                    ch := text( start(txPos) + cPos );
                    if ch not = "\" then writeon( s_w := 0, ch )
                    else begin
                        % escaped character %
                        cPos := cPos + 1;
                        if      cPos > length(txPos) then rtError( "String terminates with ""\""." )
                        else begin
                            ch := text( start(txPos) + cPos );
                            if ch = "n" then % newline % write()
                                        else writeon( s_w := 0, ch )
                        end
                    end;
                    cPos := cPos + 1
                end while_not_end_of_string
            end
        end writeOnText ;

        % returns 1 if val is true, 0 otherwise %
        integer procedure booleanResult ( logical value val ) ; begin
            if val then 1 else 0
        end booleanResult ;

        v := 0;

        if      n = null                 then v := 0
        else if type(n) = nIdentifier    then v := data( iValue(n) )
        else if type(n) = nString        then v := iValue(n)
        else if type(n) = nInteger       then v := iValue(n)
        else if type(n) = nSequence      then begin
            % sequence - evaluate and discard the left branch and return the right branch %
            v := eval(  left(n) );
            v := eval( right(n) )
            end
        else if type(n) = nIf            then % if-else         % begin
            if eval( left(n) ) not = 0 then v := eval(  left(right(n)) )
                                       else v := eval( right(right(n)) );
            v := 0
            end
        else if type(n) = nPrtc          then % print character % writeon( s_w := 0, code( eval( left(n) ) ) )
        else if type(n) = nPrts          then % print string    % writeOnText( stList, eval( left(n) ) )
        else if type(n) = nPrti          then % print integer   % writeon( s_w := 0, i_w := 1, eval( left(n) ) )
        else if type(n) = nWhile         then % while-loop      % begin
            while eval( left(n) ) not = 0 do v := eval( right(n) );
            v := 0
            end
        else if type(n) = nAssign        then % assignment      % data( iValue(left(n)) ) := eval( right(n) )
        else if type(n) = nNegate        then % unary -         % v := - eval( left(n) )
        else if type(n) = nNot           then % unary not       % v := booleanResult( eval( left(n) ) = 0 )
        else if type(n) = nMultiply      then % multiply        % v := eval( left(n) ) * eval( right(n) )
        else if type(n) = nDivide        then % division        % begin
            integer lv, rv;
            lv := eval(  left(n) );
            rv := eval( right(n) );
            if rv = 0 then rtError( "Division by 0." )
            else v := lv div rv
            end
        else if type(n) = nMod           then % modulo          % begin
            integer lv, rv;
            lv := eval(  left(n) );
            rv := eval( right(n) );
            if rv = 0 then rtError( "Right operand of % is 0." )
            else v := lv rem rv
            end
        else if type(n) = nAdd           then % addition        % v := eval( left(n) ) + eval( right(n) )
        else if type(n) = nSubtract      then % subtraction     % v := eval( left(n) ) - eval( right(n) )
        else if type(n) = nLess          then % less-than       % v := booleanResult( eval( left(n) ) <     eval( right(n) ) )
        else if type(n) = nLessEqual     then % less or equal   % v := booleanResult( eval( left(n) ) <=    eval( right(n) ) )
        else if type(n) = nGreater       then % greater-than    % v := booleanResult( eval( left(n) ) >     eval( right(n) ) )
        else if type(n) = nGreaterEqual  then % greater or eq   % v := booleanResult( eval( left(n) ) >=    eval( right(n) ) )
        else if type(n) = nEqual         then % test equal      % v := booleanResult( eval( left(n) ) =     eval( right(n) ) )
        else if type(n) = nNotEqual      then % not-equal       % v := booleanResult( eval( left(n) ) not = eval( right(n) ) )
        else if type(n) = nAnd           then % boolean "and"   % begin
            v := eval( left(n) );
            if v not = 0 then v := eval( right(n) )
            end
        else if type(n) = nOr            then % boolean "or"    % begin
            v := eval( left(n) );
            if v = 0 then v := eval( right(n) );
            end
        else % unknown node % begin
            rtError( "Unknown node type in eval." )
        end;
        v
    end eval ;

    nIdentifier      :=  1; ndName( nIdentifier      ) := "Identifier";   nString    :=  2; ndName( nString   ) := "String";
    nInteger         :=  3; ndName( nInteger         ) := "Integer";      nSequence  :=  4; ndName( nSequence ) := "Sequence";
    nIf              :=  5; ndName( nIf              ) := "If";           nPrtc      :=  6; ndName( nPrtc     ) := "Prtc";
    nPrts            :=  7; ndName( nPrts            ) := "Prts";         nPrti      :=  8; ndName( nPrti     ) := "Prti";
    nWhile           :=  9; ndName( nWhile           ) := "While";        nAssign    := 10; ndName( nAssign   ) := "Assign";
    nNegate          := 11; ndName( nNegate          ) := "Negate";       nNot       := 12; ndName( nNot      ) := "Not";
    nMultiply        := 13; ndName( nMultiply        ) := "Multiply";     nDivide    := 14; ndName( nDivide   ) := "Divide";
    nMod             := 15; ndName( nMod             ) := "Mod";          nAdd       := 16; ndName( nAdd      ) := "Add";
    nSubtract        := 17; ndName( nSubtract        ) := "Subtract";     nLess      := 18; ndName( nLess     ) := "Less";
    nLessEqual       := 19; ndName( nLessEqual       ) := "LessEqual"  ;  nGreater   := 20; ndName( nGreater  ) := "Greater";
    nGreaterEqual    := 21; ndName( nGreaterEqual    ) := "GreaterEqual"; nEqual     := 22; ndName( nEqual    ) := "Equal";
    nNotEqual        := 23; ndName( nNotEqual        ) := "NotEqual";     nAnd       := 24; ndName( nAnd      ) := "And";
    nOr              := 25; ndName( nOr              ) := "Or";
    MAX_NODE_TYPE    := 25; TEXT_MAX := 4095; textNext := 0;
    stList := idList := null;

    % parse the output from the syntax analyser and intetrpret parse tree %
    eval( readNode )
end.
Output:
3 is prime
5 is prime
7 is prime
11 is prime
...
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26

ATS[edit]

For ATS2 with a garbage collector.

(* The Rosetta Code AST interpreter in ATS2.

   This implementation reuses the AST loader of my Code Generator
   implementation. *)

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

(* Note: you might wish to add code to catch exceptions and print nice
   messages. *)

(*------------------------------------------------------------------*)

#define ATS_DYNLOADFLAG 0

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

#define NIL list_vt_nil ()
#define ::  list_vt_cons

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

exception internal_error of ()
exception bad_ast_node_type of string
exception premature_end_of_input of ()
exception bad_number_field of string
exception missing_identifier_field of ()
exception bad_quoted_string of string

(* Some implementations that are likely missing from the prelude. *)
implement g0uint2uint<sizeknd, ullintknd> x = $UN.cast x
implement g0uint2uint<ullintknd, sizeknd> x = $UN.cast x
implement g0uint2int<ullintknd, llintknd> x = $UN.cast x
implement g0int2uint<llintknd, sizeknd> x = $UN.cast x
implement g0int2int<llintknd, intknd> x = $UN.cast x

(*------------------------------------------------------------------*)

extern fn {}
skip_characters$skipworthy (c : char) :<> bool

fn {}
skip_characters {n : int}
                {i : nat | i <= n}
                (s : string n,
                 i : size_t i)
    :<> [j : int | i <= j; j <= n]
        size_t j =
  let
    fun
    loop {k : int | i <= k; k <= n}
         .<n - k>.
         (k : size_t k)
        :<> [j : int | k <= j; j <= n]
            size_t j =
      if string_is_atend (s, k) then
        k
      else if ~skip_characters$skipworthy (s[k]) then
        k
      else
        loop (succ k)
  in
    loop i
  end

fn
skip_whitespace {n : int}
                {i : nat | i <= n}
                (s : string n,
                 i : size_t i)
    :<> [j : int | i <= j; j <= n]
        size_t j =
  let
    implement
    skip_characters$skipworthy<> c =
      isspace c
  in
    skip_characters<> (s, i)
  end

fn
skip_nonwhitespace {n : int}
                   {i : nat | i <= n}
                   (s : string n,
                    i : size_t i)
    :<> [j : int | i <= j; j <= n]
        size_t j =
  let
    implement
    skip_characters$skipworthy<> c =
      ~isspace c
  in
    skip_characters<> (s, i)
  end

fn
skip_nonquote {n : int}
              {i : nat | i <= n}
              (s : string n,
               i : size_t i)
    :<> [j : int | i <= j; j <= n]
        size_t j =
  let
    implement
    skip_characters$skipworthy<> c =
      c <> '"'
  in
    skip_characters<> (s, i)
  end

fn
skip_to_end {n : int}
            {i : nat | i <= n}
            (s : string n,
             i : size_t i)
    :<> [j : int | i <= j; j <= n]
        size_t j =
  let
    implement
    skip_characters$skipworthy<> c =
      true
  in
    skip_characters<> (s, i)
  end

(*------------------------------------------------------------------*)

fn
substring_equals {n    : int}
                 {i, j : nat | i <= j; j <= n}
                 (s    : string n,
                  i    : size_t i,
                  j    : size_t j,
                  t    : string)
    :<> bool =
  let
    val m = strlen t
  in
    if j - i <> m then
      false                   (* The substring is the wrong length. *)
    else
      let
        val p_s = ptrcast s
        and p_t = ptrcast t
      in
        0 = $extfcall (int, "strncmp",
                       ptr_add<char> (p_s, i), p_t, m)
      end
  end

(*------------------------------------------------------------------*)

datatype node_type_t =
| NullNode
| 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

#define ARBITRARY_NODE_ARG 1234

datatype ast_node_t =
| ast_node_t_nil
| ast_node_t_nonnil of node_contents_t
where node_contents_t =
  @{
    node_type = node_type_t,
    node_arg = ullint,
    node_left = ast_node_t,
    node_right = ast_node_t
  }

fn
get_node_type {n : int}
              {i : nat | i <= n}
              (s : string n,
               i : size_t i)
    : [j : int | i <= j; j <= n]
      @(node_type_t,
        size_t j) =
  let
    val i_start = skip_whitespace (s, i)
    val i_end = skip_nonwhitespace (s, i_start)

    macdef eq t =
      substring_equals (s, i_start, i_end, ,(t))

    val node_type =
      if eq ";" then
        NullNode
      else if eq "Identifier" then
        Identifier
      else if eq "String" then
        String
      else if eq "Integer" then
        Integer
      else if eq "Sequence" then
        Sequence
      else if eq "If" then
        If
      else if eq "Prtc" then
        Prtc
      else if eq "Prts" then
        Prts
      else if eq "Prti" then
        Prti
      else if eq "While" then
        While
      else if eq "Assign" then
        Assign
      else if eq "Negate" then
        Negate
      else if eq "Not" then
        Not
      else if eq "Multiply" then
        Multiply
      else if eq "Divide" then
        Divide
      else if eq "Mod" then
        Mod
      else if eq "Add" then
        Add
      else if eq "Subtract" then
        Subtract
      else if eq "Less" then
        Less
      else if eq "LessEqual" then
        LessEqual
      else if eq "Greater" then
        Greater
      else if eq "GreaterEqual" then
        GreaterEqual
      else if eq "Equal" then
        Equal
      else if eq "NotEqual" then
        NotEqual
      else if eq "And" then
        And
      else if eq "Or" then
        Or
      else
        let
          val s_bad =
            strnptr2string
              (string_make_substring (s, i_start, i_end - i_start))
        in
          $raise bad_ast_node_type s_bad
        end
  in
    @(node_type, i_end)
  end

fn
get_unsigned {n : int}
             {i : nat | i <= n}
             (s : string n,
              i : size_t i)
    : [j : int | i <= j; j <= n]
      @(ullint,
        size_t j) =
  let
    val i = skip_whitespace (s, i)
    val [j : int] j = skip_nonwhitespace (s, i)
  in
    if j = i then
      $raise bad_number_field ""
    else
      let
        fun
        loop {k : int | i <= k; k <= j}
             (k : size_t k,
              v : ullint)
            : ullint =
          if k = j then
            v
          else
            let
              val c = s[k]
            in
              if ~isdigit c then
                let
                  val s_bad =
                    strnptr2string
                      (string_make_substring (s, i, j - i))
                in
                  $raise bad_number_field s_bad
                end
              else
                let
                  val digit = char2int1 c - char2int1 '0'
                  val () = assertloc (0 <= digit)
                in
                  loop (succ k, (g1i2u 10 * v) + g1i2u digit)
                end
            end
      in
        @(loop (i, g0i2u 0), j)
      end
  end

fn
get_identifier
          {n : int}
          {i : nat | i <= n}
          (s : string n,
           i : size_t i)
    : [j : int | i <= j; j <= n]
      @(string,
        size_t j) =
  let
    val i = skip_whitespace (s, i)
    val j = skip_nonwhitespace (s, i)
  in
    if i = j then
      $raise missing_identifier_field ()
    else
      let
        val ident =
          strnptr2string (string_make_substring (s, i, j - i))
      in
        @(ident, j)
      end
  end

fn
get_quoted_string
          {n : int}
          {i : nat | i <= n}
          (s : string n,
           i : size_t i)
    : [j : int | i <= j; j <= n]
      @(string,
        size_t j) =
  let
    val i = skip_whitespace (s, i)
  in
    if string_is_atend (s, i) then
      $raise bad_quoted_string ""
    else if s[i] <> '"' then
      let
        val j = skip_to_end (s, i)
        val s_bad =
          strnptr2string (string_make_substring (s, i, j - i))
      in
        $raise bad_quoted_string s_bad
      end
    else
      let
        val j = skip_nonquote (s, succ i)
      in
        if string_is_atend (s, j) then
          let
            val s_bad =
              strnptr2string (string_make_substring (s, i, j - i))
          in
            $raise bad_quoted_string s_bad
          end
        else
          let
            val quoted_string =
              strnptr2string
                (string_make_substring (s, i, succ j - i))
          in
            @(quoted_string, succ j)
          end
      end
  end

fn
collect_string
          {n       : int}
          (str     : string,
           strings : &list_vt (string, n) >> list_vt (string, m))
    : #[m : int | m == n || m == n + 1]
       [str_num : nat | str_num <= m]
       size_t str_num =
  (* This implementation uses ‘list_vt’ instead of ‘list’, so
     appending elements to the end of the list will be both efficient
     and safe. It would also have been reasonable to build a ‘list’
     backwards and then make a reversed copy. *)
  let
    fun
    find_or_extend
              {i : nat | i <= n}
              .<n - i>.
              (strings1 : &list_vt (string, n - i)
                            >> list_vt (string, m),
               i        : size_t i)
        : #[m : int | m == n - i || m == n - i + 1]
           [j  : nat | j <= n]
          size_t j =
      case+ strings1 of
      | ~ NIL =>
        let            (* The string is not there. Extend the list. *)
          prval () = prop_verify {i == n} ()
        in
          strings1 := (str :: NIL);
          i
        end
      | @ (head :: tail) =>
        if head = str then
          let                   (* The string is found. *)
            prval () = fold@ strings1
          in
            i
          end
        else
          let                   (* Continue looking. *)
            val j = find_or_extend (tail, succ i)
            prval () = fold@ strings1
          in
            j
          end

    prval () = lemma_list_vt_param strings
    val n = i2sz (length strings)
    and j = find_or_extend (strings, i2sz 0)
  in
    j
  end

fn
load_ast (inpf    : FILEref,
          idents  : &List_vt string >> _,
          strings : &List_vt string >> _)
    : ast_node_t =
  let
    fun
    recurs (idents  : &List_vt string >> _,
            strings : &List_vt string >> _)
        : ast_node_t =
      if fileref_is_eof inpf then
        $raise premature_end_of_input ()
      else
        let
          val s = strptr2string (fileref_get_line_string inpf)
          prval () = lemma_string_param s (* String length >= 0. *)

          val i = i2sz 0
          val @(node_type, i) = get_node_type (s, i)
        in
          case+ node_type of
          | NullNode () => ast_node_t_nil ()
          | Integer () =>
            let
              val @(number, _) = get_unsigned (s, i)
            in
              ast_node_t_nonnil
                @{
                  node_type = node_type,
                  node_arg = number,
                  node_left = ast_node_t_nil,
                  node_right = ast_node_t_nil
                }
            end
          | Identifier () =>
            let
              val @(ident, _) = get_identifier (s, i)
              val arg = collect_string (ident, idents)
            in
              ast_node_t_nonnil
                @{
                  node_type = node_type,
                  node_arg = g0u2u arg,
                  node_left = ast_node_t_nil,
                  node_right = ast_node_t_nil
                }
            end
          | String () =>
            let
              val @(quoted_string, _) = get_quoted_string (s, i)
              val arg = collect_string (quoted_string, strings)
            in
              ast_node_t_nonnil
                @{
                  node_type = node_type,
                  node_arg = g0u2u arg,
                  node_left = ast_node_t_nil,
                  node_right = ast_node_t_nil
                }
            end
          | _ =>
            let
              val node_left = recurs (idents, strings)
              val node_right = recurs (idents, strings)
            in
              ast_node_t_nonnil
                @{
                  node_type = node_type,
                  node_arg = g1i2u ARBITRARY_NODE_ARG,
                  node_left = node_left,
                  node_right = node_right
                }
            end
        end
  in
    recurs (idents, strings)
  end

(*------------------------------------------------------------------*)

macdef void_value = 0LL

fn
bool2llint (b : bool)
    :<> llint =
  if b then 1LL else 0LL

fun
dequote_into_array
          {p : addr}
          {n : int | 2 <= n}
          {i : nat | i <= n - 1}
          {j : int | 1 <= j; j <= n - 1}
          .<n + 1 - j>.
          (pf : !array_v (char, p, n - 1) |
           p  : ptr p,
           n  : size_t n,
           i  : size_t i,
           s  : string n,
           j  : size_t j)
    : void =
  if (j <> pred n) * (succ i < pred n) then
    let
      macdef t = !p
    in
      if s[j] = '\\' then
        begin
          if succ j = pred n then
            $raise bad_quoted_string s
          else if s[succ j] = 'n' then
            begin
              t[i] := '\n';
              dequote_into_array (pf | p, n, succ i, s, j + i2sz 2)
            end
          else if s[succ j] = '\\' then
            begin
              t[i] := '\\';
              dequote_into_array (pf | p, n, succ i, s, j + i2sz 2)
            end
          else
            $raise bad_quoted_string s
        end
      else
        begin
          t[i] := s[j];
          dequote_into_array (pf | p, n, succ i, s, succ j)
        end
    end

fn
dequote {n : int}
        (s : string n)
    : string =
  let
    val n = strlen s
    prval [n : int] EQINT () = eqint_make_guint n

    val () = assertloc (i2sz 2 <= n)

    val () = assertloc (s[0] = '"')
    and () = assertloc (s[pred n] = '"')

    val @(pf, pfgc | p) = array_ptr_alloc<char> (pred n)
    val () = array_initize_elt<char> (!p, pred n, '\0')
    val () = dequote_into_array (pf | p, n, i2sz 0, s, i2sz 1)
    val retval = strptr2string (string0_copy ($UN.cast{string} p))
    val () = array_ptr_free (pf, pfgc | p)
  in
    retval
  end

fn
fill_string_pool (string_pool : arrszref string,
                  strings     : List string)
    : void =
  let
    #define NIL list_nil ()
    #define ::  list_cons

    fun
    loop {n : nat}
         .<n>.
         (strings : list (string, n),
          i       : size_t)
        : void =
      case+ strings of
      | NIL => ()
      | head :: tail =>
        begin
          string_pool[i] := dequote (g1ofg0 head);
          loop (tail, succ i)
        end

    prval () = lemma_list_param strings
  in
    loop (strings, i2sz 0)
  end

fn
interpret_ast (outf     : FILEref,
               ast      : ast_node_t,
               datasize : size_t,
               strings  : List string)
    : llint =
  let
    prval () = lemma_list_param strings
    val num_strings = i2sz (length strings)

    val data = arrszref_make_elt<llint> (datasize, void_value)
    and string_pool = arrszref_make_elt<string> (num_strings, "")

    val () = fill_string_pool (string_pool, strings)

    fnx
    traverse (ast : ast_node_t)
        : llint =
      case+ ast of
      | ast_node_t_nil () => void_value
      | ast_node_t_nonnil contents =>
        begin
          case- contents.node_type of
          | NullNode () => $raise internal_error ()

          | If () => if_then contents
          | While () => while_do contents

          | Sequence () =>
            let
              val _ = traverse contents.node_left
              val _ = traverse contents.node_right
            in
              void_value
            end

          | Assign () =>
            let
              val- ast_node_t_nonnil contents1 = contents.node_left
              val i = contents1.node_arg
              val x = traverse contents.node_right
            in
              data[i] := x;
              void_value
            end

          | Identifier () => data[contents.node_arg]

          | Integer () => g0u2i (contents.node_arg)
          | String () => g0u2i (contents.node_arg)

          | Prtc () =>
            let
              val i = traverse contents.node_left
            in
              fprint! (outf, int2char0 (g0i2i i));
              void_value
            end
          | Prti () =>
            let
              val i = traverse contents.node_left
            in
              fprint! (outf, i);
              void_value
            end
          | Prts () =>
            let
              val i = traverse contents.node_left
            in
              fprint! (outf, string_pool[i]);
              void_value
            end

          | Negate () => unary_op (g0int_neg, contents)
          | Not () =>
            unary_op (lam x => bool2llint (iseqz x), contents)

          | Multiply () => binary_op (g0int_mul, contents)
          | Divide () => binary_op (g0int_div, contents)
          | Mod () => binary_op (g0int_mod, contents)
          | Add () => binary_op (g0int_add, contents)
          | Subtract () => binary_op (g0int_sub, contents)
          | Less () =>
            binary_op (lam (x, y) => bool2llint (x < y), contents)
          | LessEqual () =>
            binary_op (lam (x, y) => bool2llint (x <= y), contents)
          | Greater () =>
            binary_op (lam (x, y) => bool2llint (x > y), contents)
          | GreaterEqual () =>
            binary_op (lam (x, y) => bool2llint (x >= y), contents)
          | Equal () =>
            binary_op (lam (x, y) => bool2llint (x = y), contents)
          | NotEqual () =>
            binary_op (lam (x, y) => bool2llint (x <> y), contents)
          | And () =>
            binary_op (lam (x, y) =>
                         bool2llint ((isneqz x) * (isneqz y)),
                       contents)
          | Or () =>
            binary_op (lam (x, y) =>
                         bool2llint ((isneqz x) + (isneqz y)),
                       contents)
        end
    and
    if_then (contents : node_contents_t)
        : llint =
      case- (contents.node_right) of
      | ast_node_t_nonnil contents1 =>
        let
          val condition = (contents.node_left)
          and true_branch = (contents1.node_left)
          and false_branch = (contents1.node_right)

          val branch =
            if isneqz (traverse condition) then
              true_branch
            else
              false_branch

          val _ = traverse branch
        in
          void_value
        end
    and
    while_do (contents : node_contents_t)
        : llint =
      let
        val condition = contents.node_left
        and body = contents.node_right

        fun
        loop () : void =
          if isneqz (traverse condition) then
            let
              val _ = traverse body
            in
              loop ()
            end
      in
        loop ();
        void_value
      end
    and
    unary_op (operation : llint -> llint,
              contents  : node_contents_t)
        : llint =
      let
        val x = traverse contents.node_left
      in
        operation x
      end
    and
    binary_op (operation : (llint, llint) -> llint,
               contents  : node_contents_t)
        : llint =
      let
        val x = traverse contents.node_left
        val y = traverse contents.node_right
      in
        x \operation y
      end
  in
    traverse ast
  end

(*------------------------------------------------------------------*)

fn
main_program (inpf : FILEref,
              outf : FILEref)
    : int =
  let
    var idents : List_vt string = NIL
    var strings : List_vt string = NIL

    val ast = load_ast (inpf, idents, strings)

    prval () = lemma_list_vt_param idents
    val datasize = i2sz (length idents)
    val () = free idents

    val strings = list_vt2t strings

    val _ = interpret_ast (outf, ast, datasize, strings)
  in
    0
  end

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

    val outf =
      if (outfname : string) = "-" then
        stdout_ref
      else
        fileref_open_exn (outfname, file_mode_w)
  in
    main_program (inpf, outf)
  end

(*------------------------------------------------------------------*)
Output  —  primes:
$ patscc -o interp -O3 -DATS_MEMALLOC_GCBDW interp-in-ATS.dats -latslib -lgc && ./interp primes.ast
3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26

C[edit]

Tested with gcc 4.81 and later, compiles warning free with -Wall -Wextra

#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <stdarg.h>
#include <ctype.h>

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

typedef enum {
    nd_Ident, nd_String, nd_Integer, nd_Sequence, nd_If, nd_Prtc, nd_Prts, nd_Prti, nd_While,
    nd_Assign, nd_Negate, nd_Not, nd_Mul, nd_Div, nd_Mod, nd_Add, nd_Sub, nd_Lss, nd_Leq,
    nd_Gtr, nd_Geq, nd_Eql, nd_Neq, nd_And, nd_Or
} NodeType;

typedef struct Tree Tree;
struct Tree {
    NodeType node_type;
    Tree *left;
    Tree *right;
    int value;
};

// dependency: Ordered by NodeType, must remain in same order as NodeType enum

struct {
    char       *enum_text;
    NodeType   node_type;
} atr[] = {
    {"Identifier"  , nd_Ident,  },  {"String"      , nd_String,  },
    {"Integer"     , nd_Integer,},  {"Sequence"    , nd_Sequence,},
    {"If"          , nd_If,     },  {"Prtc"        , nd_Prtc,    },
    {"Prts"        , nd_Prts,   },  {"Prti"        , nd_Prti,    },
    {"While"       , nd_While,  },  {"Assign"      , nd_Assign,  },
    {"Negate"      , nd_Negate, },  {"Not"         , nd_Not,     },
    {"Multiply"    , nd_Mul,    },  {"Divide"      , nd_Div,     },
    {"Mod"         , nd_Mod,    },  {"Add"         , nd_Add,     },
    {"Subtract"    , nd_Sub,    },  {"Less"        , nd_Lss,     },
    {"LessEqual"   , nd_Leq,    },  {"Greater"     , nd_Gtr,     },
    {"GreaterEqual", nd_Geq,    },  {"Equal"       , nd_Eql,     },
    {"NotEqual"    , nd_Neq,    },  {"And"         , nd_And,     },
    {"Or"          , nd_Or,     },
};

FILE *source_fp;
da_dim(string_pool, const char *);
da_dim(global_names, const char *);
da_dim(global_values, int);

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

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

Tree *make_node(NodeType node_type, Tree *left, Tree *right) {
    Tree *t = calloc(sizeof(Tree), 1);
    t->node_type = node_type;
    t->left = left;
    t->right = right;
    return t;
}

Tree *make_leaf(NodeType node_type, int value) {
    Tree *t = calloc(sizeof(Tree), 1);
    t->node_type = node_type;
    t->value = value;
    return t;
}

int interp(Tree *x) {           /* interpret the parse tree */
    if (!x) return 0;
    switch(x->node_type) {
        case nd_Integer:  return x->value;
        case nd_Ident:    return global_values[x->value];
        case nd_String:   return x->value;

        case nd_Assign:   return global_values[x->left->value] = interp(x->right);
        case nd_Add:      return interp(x->left) +  interp(x->right);
        case nd_Sub:      return interp(x->left) -  interp(x->right);
        case nd_Mul:      return interp(x->left) *  interp(x->right);
        case nd_Div:      return interp(x->left) /  interp(x->right);
        case nd_Mod:      return interp(x->left) %  interp(x->right);
        case nd_Lss:      return interp(x->left) <  interp(x->right);
        case nd_Gtr:      return interp(x->left) >  interp(x->right);
        case nd_Leq:      return interp(x->left) <= interp(x->right);
        case nd_Eql:      return interp(x->left) == interp(x->right);
        case nd_Neq:      return interp(x->left) != interp(x->right);
        case nd_And:      return interp(x->left) && interp(x->right);
        case nd_Or:       return interp(x->left) || interp(x->right);  
        case nd_Negate:   return -interp(x->left);
        case nd_Not:      return !interp(x->left);

        case nd_If:       if (interp(x->left))
                            interp(x->right->left);
                          else
                            interp(x->right->right);
                          return 0;

        case nd_While:    while (interp(x->left))
                            interp(x->right);
                          return 0;

        case nd_Prtc:     printf("%c", interp(x->left));
                          return 0;
        case nd_Prti:     printf("%d", interp(x->left));
                          return 0;
        case nd_Prts:     printf("%s", string_pool[interp(x->left)]);
                          return 0;

        case nd_Sequence: interp(x->left);
                          interp(x->right);
                          return 0;

        default:          error("interp: unknown tree type %d\n", x->node_type);
    }
    return 0;
}

void init_in(const char fn[]) {
    if (fn[0] == '\0')
        source_fp = stdin;
    else {
        source_fp = fopen(fn, "r");
        if (source_fp == NULL)
            error("Can't open %s\n", fn);
    }
}

NodeType get_enum_value(const char name[]) {
    for (size_t i = 0; i < sizeof(atr) / sizeof(atr[0]); i++) {
        if (strcmp(atr[i].enum_text, name) == 0) {
            return atr[i].node_type;
        }
    }
    error("Unknown token %s\n", name);
    return -1;
}

char *read_line(int *len) {
    static char *text = NULL;
    static int textmax = 0;

    for (*len = 0; ; (*len)++) {
        int ch = fgetc(source_fp);
        if (ch == EOF || ch == '\n') {
            if (*len == 0)
                return NULL;
            break;
        }
        if (*len + 1 >= textmax) {
            textmax = (textmax == 0 ? 128 : textmax * 2);
            text = realloc(text, textmax);
        }
        text[*len] = ch;
    }
    text[*len] = '\0';
    return text;
}

char *rtrim(char *text, int *len) {         // remove trailing spaces
    for (; *len > 0 && isspace(text[*len - 1]); --(*len))
        ;

    text[*len] = '\0';
    return text;
}

int fetch_string_offset(char *st) {
    int len = strlen(st);
    st[len - 1] = '\0';
    ++st;
    char *p, *q;
    p = q = st;

    while ((*p++ = *q++) != '\0') {
        if (q[-1] == '\\') {
            if (q[0] == 'n') {
                p[-1] = '\n';
                ++q;
            } else if (q[0] == '\\') {
                ++q;
            }
        }
    }

    for (int i = 0; i < da_len(string_pool); ++i) {
        if (strcmp(st, string_pool[i]) == 0) {
            return i;
        }
    }
    da_add(string_pool);
    int n = da_len(string_pool) - 1;
    string_pool[n] = strdup(st);
    return da_len(string_pool) - 1;
}

int fetch_var_offset(const char *name) {
    for (int i = 0; i < da_len(global_names); ++i) {
        if (strcmp(name, global_names[i]) == 0)
            return i;
    }
    da_add(global_names);
    int n = da_len(global_names) - 1;
    global_names[n] = strdup(name);
    da_append(global_values, 0);
    return n;
}

Tree *load_ast() {
    int len;
    char *yytext = read_line(&len);
    yytext = rtrim(yytext, &len);

    // get first token
    char *tok = strtok(yytext, " ");

    if (tok[0] == ';') {
        return NULL;
    }
    NodeType node_type = get_enum_value(tok);

    // if there is extra data, get it
    char *p = tok + strlen(tok);
    if (p != &yytext[len]) {
        int n;
        for (++p; isspace(*p); ++p)
            ;
        switch (node_type) {
            case nd_Ident:      n = fetch_var_offset(p);    break;
            case nd_Integer:    n = strtol(p, NULL, 0);     break;
            case nd_String:     n = fetch_string_offset(p); break;
            default:            error("Unknown node type: %s\n", p);
        }
        return make_leaf(node_type, n);
    }

    Tree *left  = load_ast();
    Tree *right = load_ast();
    return make_node(node_type, left, right);
}

int main(int argc, char *argv[]) {
    init_in(argc > 1 ? argv[1] : "");

    Tree *x = load_ast();
    interp(x);

    return 0;
}
Output  —  prime numbers output from AST interpreter:

lex prime.t | parse | interp
3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26

COBOL[edit]

Code by Steve Williams. Tested with GnuCOBOL 2.2.

        >>SOURCE FORMAT IS FREE
identification division.
*> this code is dedicated to the public domain
*> (GnuCOBOL) 2.3-dev.0
program-id. astinterpreter.
environment division.
configuration section.
repository. function all intrinsic.
data division.
working-storage section.
01  program-name pic x(32) value spaces global.
01  input-name pic x(32) value spaces global.
01  input-status pic xx global.

01  ast-record global.
    03  ast-type pic x(14).
    03  ast-value pic x(48).
    03  filler redefines ast-value.
        05  asl-left pic 999.
        05  asl-right pic 999.

01  error-record pic x(64) value spaces global.

01  loadstack global.
    03  l pic 99 value 0.
    03  l-lim pic 99 value 64.
    03  load-entry occurs 64.
        05  l-node pic x(14).
        05  l-left pic 999.
        05  l-right pic 999.
        05  l-link pic 999.

01  abstract-syntax-tree global.
    03  t pic 999 value 0.
    03  t1 pic 999.
    03  n1 pic 999.
    03  t-lim pic 999 value 998.
    03  filler occurs 998.
        05  leaf.
            07  leaf-type pic x(14).
            07  leaf-value pic x(48).
        05  node redefines leaf.
            07  node-type pic x(14).
            07  node-left pic 999.
            07  node-right pic 999.


01  interpreterstack global.
    03  stack1 pic 99 value 2.
    03  stack2 pic 99 value 1.
    03  stack-lim pic 99 value 32.
    03  stack-entry occurs 32.
         05  stack-source pic 99.
         05  stack usage binary-int.

01  variables global.
    03  v pic 99.
    03  v-max pic 99 value 0.
    03  v-lim pic 99 value 16.
    03  filler occurs 16.
        05  variable-value binary-int.
        05  variable-name pic x(48).

01  strings global.
    03  s pic 99.
    03  s-max pic 99 value 0.
    03  s-lim pic 99 value 16.
    03  filler occurs 16 value spaces.
        05  string-value pic x(48).

01  string-fields global.
    03  string-length pic 99.
    03  string1 pic 99.
    03  length1 pic 99.
    03  count1 pic 99.

01  display-fields global.
    03  display-number pic -(9)9.
    03  display-pending pic x value 'n'.
    03  character-value.
        05  character-number usage binary-char.

procedure division chaining program-name.
start-astinterpreter.
    call 'loadast'
    if program-name <> spaces
        call 'readinput' *> close the input-file
    end-if
    >>d perform print-ast
    call 'runast' using t
    if display-pending = 'y'
        display space
    end-if
    stop run
    .
print-ast.
    call 'printast' using t
    display 'ast:' upon syserr
    display 't=' t
    perform varying t1 from 1 by 1 until t1 > t
        if leaf-type(t1) = 'Identifier' or 'Integer' or 'String'
            display t1 space trim(leaf-type(t1)) space trim(leaf-value(t1)) upon syserr
        else
            display t1 space node-left(t1) space node-right(t1) space trim(node-type(t1)) 
                upon syserr
        end-if
    end-perform
    .

identification division.
program-id. runast common recursive.
data division.
working-storage section.
01  word-length constant as length of binary-int.
linkage section.
01  n pic 999.
procedure division using n.
start-runast.
    if n = 0
        exit program
    end-if
    evaluate node-type(n)
    when 'Integer'
        perform push-stack
        move numval(leaf-value(n)) to stack(stack1)
    when 'Identifier'
        perform get-variable-index
        perform push-stack
        move v to stack-source(stack1)
        move variable-value(v) to stack(stack1)
    when 'String'
        perform get-string-index
        perform push-stack
        move s to stack-source(stack1)
    when 'Assign'
        call 'runast' using node-left(n)
        call 'runast' using node-right(n)
        move stack-source(stack2) to v
        move stack(stack1) to variable-value(v)
        perform pop-stack
        perform pop-stack
    when 'If'
        call 'runast' using node-left(n)
        move node-right(n) to n1
        if stack(stack1) <> 0
            call 'runast' using node-left(n1)
        else
            call 'runast' using node-right(n1)
        end-if
        perform pop-stack
    when 'While'
        call 'runast' using node-left(n)
        perform until stack(stack1) = 0
            perform pop-stack
            call 'runast' using node-right(n)
            call 'runast' using node-left(n)
        end-perform
        perform pop-stack
    when 'Add'
        perform get-values
        add stack(stack1) to stack(stack2)
        perform pop-stack
    when 'Subtract'
        perform get-values
        subtract stack(stack1) from stack(stack2)
        perform pop-stack
    when 'Multiply'
        perform get-values
        multiply stack(stack1) by stack(stack2)
        perform pop-stack
    when 'Divide'
        perform get-values
        divide stack(stack1) into stack(stack2)
        perform pop-stack
    when 'Mod'
        perform get-values
        move mod(stack(stack2),stack(stack1)) to stack(stack2)
        perform pop-stack
    when 'Less'
        perform get-values
        if stack(stack2) < stack(stack1)
            move 1 to stack(stack2)
        else
            move 0 to stack(stack2)
        end-if
        perform pop-stack
    when 'Greater'
        perform get-values
        if stack(stack2) > stack(stack1)
            move 1 to stack(stack2)
        else
            move 0 to stack(stack2)
        end-if
        perform pop-stack
    when 'LessEqual'
        perform get-values
        if stack(stack2) <= stack(stack1)
            move 1 to stack(stack2)
        else
            move 0 to stack(stack2)
        end-if
        perform pop-stack
    when 'GreaterEqual'
        perform get-values
        if stack(stack2) >= stack(stack1)
            move 1 to stack(stack2)
        else
            move 0 to stack(stack2)
        end-if
        perform pop-stack
    when 'Equal'
        perform get-values
        if stack(stack2) = stack(stack1)
            move 1 to stack(stack2)
        else
            move 0 to stack(stack2)
        end-if
        perform pop-stack
    when 'NotEqual'
        perform get-values
        if stack(stack2) <> stack(stack1)
            move 1 to stack(stack2)
        else
            move 0 to stack(stack2)
        end-if
        perform pop-stack
    when 'And'
        perform get-values
        call "CBL_AND" using stack(stack1) stack(stack2) by value word-length
        perform pop-stack
    when 'Or'
        perform get-values
        call "CBL_OR" using stack(stack1) stack(stack2) by value word-length
        perform pop-stack
    when 'Not'
        call 'runast' using node-left(n)
        if stack(stack1) = 0
            move 1 to stack(stack1)
        else
            move 0 to stack(stack1)
        end-if
    when 'Negate'
        call 'runast' using node-left(n)
        compute stack(stack1) = - stack(stack1)
    when 'Prtc'
        call 'runast' using node-left(n)
        move stack(stack1) to character-number
        display character-value with no advancing
        move 'y' to display-pending
        perform pop-stack
    when 'Prti'
        call 'runast' using node-left(n)
        move stack(stack1) to display-number
        display trim(display-number) with no advancing
        move 'y' to display-pending
        perform pop-stack
    when 'Prts'
        call 'runast' using node-left(n)
        move stack-source(stack1) to s
        move length(trim(string-value(s))) to string-length
        move 2 to string1
        compute length1 = string-length - 2
        perform until string1 >= string-length
            move 0 to count1
            inspect string-value(s)(string1:length1)
                tallying count1 for characters before initial '\'   *> ' (workaround Rosetta Code highlighter problem)
            evaluate true
            when string-value(s)(string1 + count1 + 1:1) = 'n' *> \n
                display string-value(s)(string1:count1)
                move 'n' to display-pending
                compute string1 = string1 + 2 + count1
                compute length1 = length1 - 2 - count1
            when string-value(s)(string1 + count1 + 1:1) = '\' *> \\ '
                display string-value(s)(string1:count1 + 1) with no advancing
                move 'y' to display-pending
                compute string1 = string1 + 2 + count1
                compute length1 = length1 - 2 - count1
            when other
                display string-value(s)(string1:count1) with no advancing
                move 'y' to display-pending
                add count1 to string1
                subtract count1 from length1
            end-evaluate
        end-perform 
        perform pop-stack
    when 'Sequence'
        call 'runast' using node-left(n)
        call 'runast' using node-right(n)
    when other
        string 'in astinterpreter unknown node type ' node-type(n) into error-record
        call 'reporterror'
    end-evaluate
    exit program
    .
push-stack.
    if stack1 >= s-lim
        string 'in astinterpreter at ' n ' stack overflow' into error-record
        call 'reporterror'
    end-if
    add 1 to stack1 stack2
    initialize stack-entry(stack1)
    .
pop-stack.
    if stack1 < 2
        string 'in astinterpreter at ' n ' stack underflow ' into error-record
        call 'reporterror'
    end-if
    subtract 1 from stack1 stack2
    .
get-variable-index.
    perform varying v from 1 by 1 until v > v-max
    or variable-name(v) = leaf-value(n)
        continue
    end-perform
    if v > v-max
        if v-max = v-lim
            string 'in astinterpreter number of variables exceeds ' v-lim into error-record
            call 'reporterror'
        end-if
        move v to v-max
        move leaf-value(n) to variable-name(v)
        move 0 to variable-value(v)
    end-if
    .
get-string-index.
    perform varying s from 1 by 1 until s > s-max
    or string-value(s) = leaf-value(n)
        continue
    end-perform
    if s > s-max
        if s-max = s-lim
            string 'in astinterpreter number of strings exceeds ' s-lim into error-record
            call 'reporterror'
        end-if
        move s to s-max
        move leaf-value(n) to string-value(s)
    end-if
    .
get-values.
    call 'runast' using node-left(n)
    call 'runast' using node-right(n)
    .
end program runast.

identification division.
program-id. loadast common recursive.
procedure division.
start-loadast.
    if l >= l-lim
        string 'in astinterpreter loadast l exceeds ' l-lim into error-record
        call 'reporterror'
    end-if
    add 1 to l
    call 'readinput'
    evaluate true
    when ast-record = ';'
    when input-status = '10'
        move 0 to return-code
    when ast-type = 'Identifier'
    when ast-type = 'Integer'
    when ast-type = 'String'
        call 'makeleaf' using ast-type ast-value
        move t to return-code
    when ast-type = 'Sequence'
        move ast-type to l-node(l)
        call 'loadast'
        move return-code to l-left(l)
        call 'loadast'
        move t to l-right(l)
        call 'makenode' using l-node(l) l-left(l) l-right(l)
        move t to return-code
    when other
        move ast-type to l-node(l)
        call 'loadast'
        move return-code to l-left(l)
        call 'loadast'
        move return-code to l-right(l)
        call 'makenode' using l-node(l) l-left(l) l-right(l)
        move t to return-code
    end-evaluate
    subtract 1 from l
    .
end program loadast.

identification division.
program-id. makenode common.
data division.
linkage section.
01  parm-type any length.
01  parm-l-left pic 999.
01  parm-l-right pic 999.
procedure division using parm-type parm-l-left parm-l-right.
start-makenode.
    if t >= t-lim 
        string 'in astinterpreter makenode t exceeds ' t-lim into error-record
        call 'reporterror'
    end-if
    add 1 to t
    move parm-type to node-type(t)
    move parm-l-left to node-left(t)
    move parm-l-right to node-right(t)
    .
end program makenode.

identification division.
program-id. makeleaf common.
data division.
linkage section.
01  parm-type any length.
01  parm-value pic x(48).
procedure division using parm-type parm-value.
start-makeleaf.
    add 1 to t
    if t >= t-lim 
        string 'in astinterpreter makeleaf t exceeds ' t-lim into error-record
        call 'reporterror'
    end-if
    move parm-type to leaf-type(t)
    move parm-value to leaf-value(t)
    .
end program makeleaf.

identification division.
program-id. printast common recursive.
data division.
linkage section.
01  n pic 999.
procedure division using n.
start-printast.
    if n = 0
        display ';' upon syserr
        exit program
    end-if
    display leaf-type(n) upon syserr
    evaluate leaf-type(n)
    when 'Identifier'
    when 'Integer'
    when 'String'
        display leaf-type(n) space trim(leaf-value(n)) upon syserr
    when other
        display node-type(n) upon syserr
        call 'printast' using node-left(n)
        call 'printast' using node-right(n)
    end-evaluate
    .
end program printast.

identification division.
program-id. readinput common.
environment division.
input-output section.
file-control.
    select input-file assign using input-name
        status is input-status
        organization is line sequential.
data division.
file section.
fd  input-file.
01  input-record pic x(64).
procedure division.
start-readinput.
    if program-name = spaces
        move '00' to input-status
        accept ast-record on exception move '10' to input-status end-accept
        exit program
    end-if
    if input-name = spaces
        string program-name delimited by space '.ast' into input-name
        open input input-file
        if input-status = '35'
            string 'in astinterpreter ' trim(input-name) ' not found' into error-record
            call 'reporterror'
        end-if
    end-if
    read input-file into ast-record
    evaluate input-status
    when '00'
        continue
    when '10'
        close input-file
    when other
        string 'in astinterpreter ' trim(input-name) ' unexpected input-status: ' input-status
            into error-record
        call 'reporterror'
    end-evaluate
    .
end program readinput.

program-id. reporterror common.
procedure division.
start-reporterror.
report-error.
    display error-record upon syserr
    stop run with error status -1
    .
end program reporterror.
end program astinterpreter.
Output  —  Primes:
prompt$ ./lexer <testcases/Primes | ./parser | ./astinterpreter 
3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26

Forth[edit]

Tested with Gforth 0.7.3

CREATE BUF 0 ,              \ single-character look-ahead buffer
: PEEK   BUF @ 0= IF KEY BUF ! THEN BUF @ ;
: GETC   PEEK  0 BUF ! ;
: SPACE?   DUP BL = SWAP  9 14 WITHIN  OR ;
: >SPACE   BEGIN PEEK SPACE? WHILE GETC DROP REPEAT ;
: DIGIT?   48 58 WITHIN ;
: GETINT   >SPACE  0
   BEGIN  PEEK DIGIT?
   WHILE  GETC [CHAR] 0 -  SWAP 10 * +  REPEAT ;
: GETNAM   >SPACE PAD 1+
   BEGIN PEEK SPACE? INVERT
   WHILE GETC OVER C! CHAR+
   REPEAT  PAD TUCK - 1-  PAD C! ;
: GETSTR ( -- c-addr u)
   HERE >R 0  >SPACE GETC DROP  \ skip leading "
   BEGIN GETC DUP [CHAR] " <> WHILE C, 1+ REPEAT
   DROP R> SWAP ;
: \TYPE   BEGIN DUP 0> WHILE
   OVER C@ [CHAR] \ = IF
     1- >R CHAR+ R>
     OVER C@ [CHAR] n = IF CR ELSE
     OVER C@ [CHAR] \ = IF [CHAR] \ EMIT THEN THEN
   ELSE OVER C@ EMIT THEN  1- >R CHAR+ R> REPEAT
   DROP DROP ;
: .   S>D SWAP OVER DABS <# #S ROT SIGN #> TYPE ;

: CONS ( v l -- l)  HERE >R SWAP , , R> ;
: HEAD ( l -- v)  @ ;
: TAIL ( l -- l)  CELL+ @ ;
CREATE GLOBALS 0 ,
: DECLARE ( c-addr -- a-addr)  HERE TUCK
   OVER C@ CHAR+  DUP ALLOT CMOVE  HERE SWAP 0 ,
   GLOBALS @ CONS  GLOBALS ! ;
: LOOKUP ( c-addr -- a-addr)  DUP COUNT  GLOBALS @ >R
   BEGIN R@ 0<>
   WHILE R@ HEAD COUNT  2OVER COMPARE 0=
     IF 2DROP DROP  R> HEAD DUP C@ CHAR+ + EXIT
     THEN  R> TAIL >R
   REPEAT
   2DROP RDROP  DECLARE ;

DEFER GETAST
: >Identifier   GETNAM LOOKUP  0 ;
: >Integer   GETINT  0 ;
: >String   GETSTR ;
: >;   0 0 ;
: NODE ( xt left right -- addr)  HERE >R , , , R> ;
CREATE BUF' 12 ALLOT
: PREPEND ( c-addr c -- c-addr)  BUF' 1+ C!
   COUNT DUP 1+ BUF' C!  BUF' 2 + SWAP CMOVE  BUF' ;
: HANDLER ( c-addr -- xt)  [CHAR] $ PREPEND  FIND
   0= IF ." No handler for AST node '" COUNT TYPE ." '" THEN ;
: READER ( c-addr -- xt t | f)
   [CHAR] > PREPEND  FIND  DUP 0= IF NIP THEN ;
: READ ( c-addr -- left right)  READER
   IF EXECUTE ELSE GETAST GETAST THEN ;
: (GETAST)   GETNAM  DUP HANDLER SWAP  READ  NODE ;
' (GETAST) IS GETAST

: INTERP   DUP 2@  ROT [ 2 CELLS ]L + @ EXECUTE ;
: $;   DROP DROP ;
: $Identifier ( l r -- a-addr)  DROP @ ;
: $Integer ( l r -- n)  DROP ;
: $String ( l r -- c-addr u)  ( noop) ;
: $Prtc ( l r --)  DROP INTERP EMIT ;
: $Prti ( l r --)  DROP INTERP . ;
: $Prts ( l r --)  DROP INTERP \TYPE ;
: $Not ( l r --)  DROP INTERP 0= ;
: $Negate ( l r --) DROP INTERP NEGATE ;
: $Sequence ( l r --) SWAP INTERP INTERP ;
: $Assign ( l r --)  SWAP CELL+ @ >R  INTERP  R> ! ;
: $While ( l r --)
   >R BEGIN DUP INTERP WHILE R@ INTERP REPEAT  RDROP DROP ;
: $If ( l r --)  SWAP INTERP 0<> IF CELL+ THEN @ INTERP ;
: $Subtract ( l r -- n) >R INTERP R> INTERP - ;
: $Add   >R INTERP R> INTERP + ;
: $Mod   >R INTERP R> INTERP MOD ;
: $Multiply   >R INTERP R> INTERP * ;
: $Divide   >R INTERP S>D R> INTERP SM/REM SWAP DROP ;
: $Less   >R INTERP R> INTERP < ;
: $LessEqual   >R INTERP R> INTERP <= ;
: $Greater   >R INTERP R> INTERP > ;
: $GreaterEqual   >R INTERP R> INTERP >= ;
: $Equal   >R INTERP R> INTERP = ;
: $NotEqual   >R INTERP R> INTERP <> ;
: $And   >R INTERP IF R> INTERP 0<> ELSE RDROP 0 THEN ;
: $Or   >R INTERP IF RDROP -1 ELSE R> INTERP 0<> THEN ;

GETAST INTERP

Passes all tests.

Fortran[edit]

Works with: gfortran version 11.2.1

The code is Fortran 2008/2018 with the C preprocessor. On case-sensitive systems, you can name the source file Interp.F90, with a capital F, so gfortran will know (without an option flag) to invoke the C preprocessor.

!!!
!!! An implementation of the Rosetta Code interpreter task:
!!! https://rosettacode.org/wiki/Compiler/AST_interpreter
!!!
!!! 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

  ! Synonyms for integers in the runtime code.
  integer, parameter, public :: runtime_int_kind = int64
  integer, parameter, public :: rik = runtime_int_kind
end module compiler_type_kinds

module helper_procedures
  use, non_intrinsic :: compiler_type_kinds, only: nk, ck

  implicit none
  private

  public :: new_storage_size
  public :: next_power_of_two
  public :: isspace

  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_' '

contains

  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


  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 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

end module helper_procedures

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
  use, non_intrinsic :: helper_procedures

  implicit none
  private

  public :: strbuf_t
  public :: skip_whitespace
  public :: skip_non_whitespace
  public :: skip_whitespace_backwards
  public :: at_end_of_line

  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

  subroutine strbuf_t_ensure_storage (strbuf, length_needed)
    class(strbuf_t), intent(inout) :: strbuf
    integer(kind = nk), intent(in) :: length_needed

    integer(kind = nk) :: len_needed
    integer(kind = nk) :: new_size
    type(strbuf_t) :: new_strbuf

    len_needed = max (length_needed, 1_nk)

    if (.not. allocated (strbuf%chars)) then
       ! Initialize a new strbuf%chars array.
       new_size = new_storage_size (len_needed)
       allocate (strbuf%chars(1:new_size))
    else if (ubound (strbuf%chars, 1) < len_needed) then
       ! Allocate a new strbuf%chars array, larger than the current
       ! one, but containing the same characters.
       new_size = new_storage_size (len_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

  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

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 ast_reader

  !
  ! The AST will be read into an array. Perhaps that will improve
  ! locality, compared to storing the AST as many linked heap nodes.
  !
  ! In any case, implementing the AST this way is an interesting
  ! problem.
  !

  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, rik
  use, non_intrinsic :: helper_procedures, only: next_power_of_two
  use, non_intrinsic :: helper_procedures, only: new_storage_size
  use, non_intrinsic :: string_buffers
  use, non_intrinsic :: reading_one_line_from_a_stream

  implicit none
  private

  public :: symbol_table_t
  public :: interpreter_ast_node_t
  public :: interpreter_ast_t
  public :: read_ast

  integer, parameter, public :: node_Nil = 0
  integer, parameter, public :: node_Identifier = 1
  integer, parameter, public :: node_String = 2
  integer, parameter, public :: node_Integer = 3
  integer, parameter, public :: node_Sequence = 4
  integer, parameter, public :: node_If = 5
  integer, parameter, public :: node_Prtc = 6
  integer, parameter, public :: node_Prts = 7
  integer, parameter, public :: node_Prti = 8
  integer, parameter, public :: node_While = 9
  integer, parameter, public :: node_Assign = 10
  integer, parameter, public :: node_Negate = 11
  integer, parameter, public :: node_Not = 12
  integer, parameter, public :: node_Multiply = 13
  integer, parameter, public :: node_Divide = 14
  integer, parameter, public :: node_Mod = 15
  integer, parameter, public :: node_Add = 16
  integer, parameter, public :: node_Subtract = 17
  integer, parameter, public :: node_Less = 18
  integer, parameter, public :: node_LessEqual = 19
  integer, parameter, public :: node_Greater = 20
  integer, parameter, public :: node_GreaterEqual = 21
  integer, parameter, public :: node_Equal = 22
  integer, parameter, public :: node_NotEqual = 23
  integer, parameter, public :: node_And = 24
  integer, parameter, public :: node_Or = 25

  type :: symbol_table_element_t
     character(:, kind = ck), allocatable :: str
  end type symbol_table_element_t

  type :: symbol_table_t
     integer(kind = nk), private :: len = 0_nk
     type(symbol_table_element_t), allocatable, private :: symbols(:)
   contains
     procedure, pass, private :: ensure_storage => symbol_table_t_ensure_storage
     procedure, pass :: look_up_index => symbol_table_t_look_up_index
     procedure, pass :: look_up_name => symbol_table_t_look_up_name
     procedure, pass :: length => symbol_table_t_length
     generic :: look_up => look_up_index
     generic :: look_up => look_up_name
  end type symbol_table_t

  type :: interpreter_ast_node_t
     integer :: node_variety
     integer(kind = rik) :: int ! Runtime integer or symbol index.
     character(:, kind = ck), allocatable :: str ! String value.

     ! The left branch begins at the next node. The right branch
     ! begins at the address of the left branch, plus the following.
     integer(kind = nk) :: right_branch_offset
  end type interpreter_ast_node_t

  type :: interpreter_ast_t
     integer(kind = nk), private :: len = 0_nk
     type(interpreter_ast_node_t), allocatable, public :: nodes(:)
   contains
     procedure, pass, private :: ensure_storage => interpreter_ast_t_ensure_storage
  end type interpreter_ast_t

contains

  subroutine symbol_table_t_ensure_storage (symtab, length_needed)
    class(symbol_table_t), intent(inout) :: symtab
    integer(kind = nk), intent(in) :: length_needed

    integer(kind = nk) :: len_needed
    integer(kind = nk) :: new_size
    type(symbol_table_t) :: new_symtab

    len_needed = max (length_needed, 1_nk)

    if (.not. allocated (symtab%symbols)) then
       ! Initialize a new symtab%symbols array.
       new_size = new_storage_size (len_needed)
       allocate (symtab%symbols(1:new_size))
    else if (ubound (symtab%symbols, 1) < len_needed) then
       ! Allocate a new symtab%symbols array, larger than the current
       ! one, but containing the same symbols.
       new_size = new_storage_size (len_needed)
       allocate (new_symtab%symbols(1:new_size))
       new_symtab%symbols(1:symtab%len) = symtab%symbols(1:symtab%len)
       call move_alloc (new_symtab%symbols, symtab%symbols)
    end if
  end subroutine symbol_table_t_ensure_storage

  elemental function symbol_table_t_length (symtab) result (len)
    class(symbol_table_t), intent(in) :: symtab
    integer(kind = nk) :: len

    len = symtab%len
  end function symbol_table_t_length

  function symbol_table_t_look_up_index (symtab, symbol_name) result (index)
    class(symbol_table_t), intent(inout) :: symtab
    character(*, kind = ck), intent(in) :: symbol_name
    integer(kind = rik) :: index

    !
    ! This implementation simply stores the symbols sequentially into
    ! an array. Obviously, for large numbers of symbols, one might
    ! wish to do something more complex.
    !
    ! Standard Fortran does not come, out of the box, with a massive
    ! runtime library for doing such things. They are, however, no
    ! longer nearly as challenging to implement in Fortran as they
    ! used to be.
    !

    integer(kind = nk) :: i

    i = 1
    index = 0
    do while (index == 0)
       if (i == symtab%len + 1) then
          ! The symbol is new and must be added to the table.
          i = symtab%len + 1
          if (huge (1_rik) < i) then
             ! Symbol indices are assumed to be storable as runtime
             ! integers.
             write (error_unit, '("There are more symbols than can be handled.")')
             stop 1
          end if
          call symtab%ensure_storage(i)
          symtab%len = i
          allocate (symtab%symbols(i)%str, source = symbol_name)
          index = int (i, kind = rik)
       else if (symtab%symbols(i)%str == symbol_name) then
          index = int (i, kind = rik)
       else
          i = i + 1
       end if
    end do
  end function symbol_table_t_look_up_index

  function symbol_table_t_look_up_name (symtab, index) result (symbol_name)
    class(symbol_table_t), intent(inout) :: symtab
    integer(kind = rik), intent(in) :: index
    character(:, kind = ck), allocatable :: symbol_name

    !
    ! This is the reverse of symbol_table_t_look_up_index: given an
    ! index, it finds the symbol’s name.
    !

    if (index < 1 .or. symtab%len < index) then
       ! In correct code, this branch should never be reached.
       error stop
    else
       allocate (symbol_name, source = symtab%symbols(index)%str)
    end if
  end function symbol_table_t_look_up_name

  subroutine interpreter_ast_t_ensure_storage (ast, length_needed)
    class(interpreter_ast_t), intent(inout) :: ast
    integer(kind = nk), intent(in) :: length_needed

    integer(kind = nk) :: len_needed
    integer(kind = nk) :: new_size
    type(interpreter_ast_t) :: new_ast

    len_needed = max (length_needed, 1_nk)

    if (.not. allocated (ast%nodes)) then
       ! Initialize a new ast%nodes array.
       new_size = new_storage_size (len_needed)
       allocate (ast%nodes(1:new_size))
    else if (ubound (ast%nodes, 1) < len_needed) then
       ! Allocate a new ast%nodes array, larger than the current one,
       ! but containing the same nodes.
       new_size = new_storage_size (len_needed)
       allocate (new_ast%nodes(1:new_size))
       new_ast%nodes(1:ast%len) = ast%nodes(1:ast%len)
       call move_alloc (new_ast%nodes, ast%nodes)
    end if
  end subroutine interpreter_ast_t_ensure_storage

  subroutine read_ast (unit_no, strbuf, ast, symtab)
    integer, intent(in) :: unit_no
    type(strbuf_t), intent(inout) :: strbuf
    type(interpreter_ast_t), intent(inout) :: ast
    type(symbol_table_t), intent(inout) :: symtab

    logical :: eof
    logical :: no_newline
    integer(kind = nk) :: after_ast_address
    
    symtab%len = 0
    ast%len = 0
    call build_subtree (1_nk, after_ast_address)

  contains

    recursive subroutine build_subtree (here_address, after_subtree_address)
      integer(kind = nk), value :: here_address
      integer(kind = nk), intent(out) :: after_subtree_address

      integer :: node_variety
      integer(kind = nk) :: i, j
      integer(kind = nk) :: left_branch_address
      integer(kind = nk) :: right_branch_address

      ! Get a line from the parser output.
      call get_line_from_stream (unit_no, eof, no_newline, strbuf)

      if (eof) then
         call ast_error
      else
         ! Prepare to store a new node.
         call ast%ensure_storage(here_address)
         ast%len = here_address

         ! What sort of node is it?
         i = skip_whitespace (strbuf, 1_nk)
         j = skip_non_whitespace (strbuf, i)
         node_variety = strbuf_to_node_variety (strbuf, i, j - 1)

         ast%nodes(here_address)%node_variety = node_variety

         select case (node_variety)
         case (node_Nil)
            after_subtree_address = here_address + 1
         case (node_Identifier)
            i = skip_whitespace (strbuf, j)
            j = skip_non_whitespace (strbuf, i)
            ast%nodes(here_address)%int = &
                 &   strbuf_to_symbol_index (strbuf, i, j - 1, symtab)
            after_subtree_address = here_address + 1
         case (node_String)
            i = skip_whitespace (strbuf, j)
            j = skip_whitespace_backwards (strbuf, strbuf%length())
            ast%nodes(here_address)%str = strbuf_to_string (strbuf, i, j)
            after_subtree_address = here_address + 1
         case (node_Integer)
            i = skip_whitespace (strbuf, j)
            j = skip_non_whitespace (strbuf, i)
            ast%nodes(here_address)%int = strbuf_to_int (strbuf, i, j - 1)
            after_subtree_address = here_address + 1
         case default
            ! The node is internal, and has left and right branches.
            ! The left branch will start at left_branch_address; the
            ! right branch will start at left_branch_address +
            ! right_side_offset.
            left_branch_address = here_address + 1
            ! Build the left branch.
            call build_subtree (left_branch_address, right_branch_address)
            ! Build the right_branch.
            call build_subtree (right_branch_address, after_subtree_address)
            ast%nodes(here_address)%right_branch_offset = &
                 &   right_branch_address - left_branch_address
         end select

      end if
    end subroutine build_subtree
    
  end subroutine read_ast

  function strbuf_to_node_variety (strbuf, i, j) result (node_variety)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i, j
    integer :: node_variety

    !
    ! This function has not been optimized in any way, unless the
    ! Fortran compiler can optimize it.
    !
    ! Something like a ‘radix tree search’ could be done on the
    ! characters of the strbuf. Or a perfect hash function. Or a
    ! binary search. Etc.
    !

    if (j == i - 1) then
       call ast_error
    else
       select case (strbuf%to_unicode(i, j))
       case (ck_";")
          node_variety = node_Nil
       case (ck_"Identifier")
          node_variety = node_Identifier
       case (ck_"String")
          node_variety = node_String
       case (ck_"Integer")
          node_variety = node_Integer
       case (ck_"Sequence")
          node_variety = node_Sequence
       case (ck_"If")
          node_variety = node_If
       case (ck_"Prtc")
          node_variety = node_Prtc
       case (ck_"Prts")
          node_variety = node_Prts
       case (ck_"Prti")
          node_variety = node_Prti
       case (ck_"While")
          node_variety = node_While
       case (ck_"Assign")
          node_variety = node_Assign
       case (ck_"Negate")
          node_variety = node_Negate
       case (ck_"Not")
          node_variety = node_Not
       case (ck_"Multiply")
          node_variety = node_Multiply
       case (ck_"Divide")
          node_variety = node_Divide
       case (ck_"Mod")
          node_variety = node_Mod
       case (ck_"Add")
          node_variety = node_Add
       case (ck_"Subtract")
          node_variety = node_Subtract
       case (ck_"Less")
          node_variety = node_Less
       case (ck_"LessEqual")
          node_variety = node_LessEqual
       case (ck_"Greater")
          node_variety = node_Greater
       case (ck_"GreaterEqual")
          node_variety = node_GreaterEqual
       case (ck_"Equal")
          node_variety = node_Equal
       case (ck_"NotEqual")
          node_variety = node_NotEqual
       case (ck_"And")
          node_variety = node_And
       case (ck_"Or")
          node_variety = node_Or
       case default
          call ast_error
       end select
    end if
  end function strbuf_to_node_variety

  function strbuf_to_symbol_index (strbuf, i, j, symtab) result (int)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i, j
    type(symbol_table_t), intent(inout) :: symtab
    integer(kind = rik) :: int

    if (j == i - 1) then
       call ast_error
    else
       int = symtab%look_up(strbuf%to_unicode (i, j))
    end if
  end function strbuf_to_symbol_index

  function strbuf_to_int (strbuf, i, j) result (int)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i, j
    integer(kind = rik) :: int

    integer :: stat
    character(:, kind = ck), allocatable :: str

    if (j < i) then
       call ast_error
    else
       allocate (character(len = (j - i) + 1_nk, kind = ck) :: str)
       str = strbuf%to_unicode (i, j)
       read (str, *, iostat = stat) int
       if (stat /= 0) then
          call ast_error
       end if
    end if
  end function strbuf_to_int

  function strbuf_to_string (strbuf, i, j) result (str)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i, j
    character(:, kind = ck), allocatable :: str

    character(1, kind = ck), parameter :: linefeed_char = char (10, kind = ck)
    character(1, kind = ck), parameter :: backslash_char = char (92, kind = ck)

    ! The following is correct for Unix and its relatives.
    character(1, kind = ck), parameter :: newline_char = linefeed_char

    integer(kind = nk) :: k
    integer(kind = nk) :: count

    if (strbuf%chars(i) /= ck_'"' .or. strbuf%chars(j) /= ck_'"') then
       call ast_error
    else
       ! Count how many characters are needed.
       count = 0
       k = i + 1
       do while (k < j)
          count = count + 1
          if (strbuf%chars(k) == backslash_char) then
             k = k + 2
          else
             k = k + 1
          end if
       end do

       allocate (character(len = count, kind = ck) :: str)

       count = 0
       k = i + 1
       do while (k < j)
          if (strbuf%chars(k) == backslash_char) then
             if (k == j - 1) then
                call ast_error
             else
                select case (strbuf%chars(k + 1))
                case (ck_'n')
                   count = count + 1
                   str(count:count) = newline_char
                case (backslash_char)
                   count = count + 1
                   str(count:count) = backslash_char
                case default
                   call ast_error
                end select
                k = k + 2
             end if
          else
             count = count + 1
             str(count:count) = strbuf%chars(k)
             k = k + 1
          end if
       end do
    end if
  end function strbuf_to_string

  subroutine ast_error
    !
    ! It might be desirable to give more detail.
    !
    write (error_unit, '("The AST input seems corrupted.")')
    stop 1
  end subroutine ast_error

end module ast_reader

module ast_interpreter
  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
  use, non_intrinsic :: ast_reader

  implicit none
  private

  public :: value_t
  public :: variable_table_t
  public :: nil_value
  public :: interpret_ast_node

  integer, parameter, public :: v_Nil = 0
  integer, parameter, public :: v_Integer = 1
  integer, parameter, public :: v_String = 2

  type :: value_t
     integer :: tag = v_Nil
     integer(kind = rik) :: int_val = -(huge (1_rik))
     character(:, kind = ck), allocatable :: str_val
  end type value_t

  type :: variable_table_t
     type(value_t), allocatable :: vals(:)
   contains
     procedure, pass :: initialize => variable_table_t_initialize
  end type variable_table_t

  ! The canonical nil value.
  type(value_t), parameter :: nil_value = value_t ()

contains

  elemental function int_value (int_val) result (val)
    integer(kind = rik), intent(in) :: int_val
    type(value_t) :: val

    val%tag = v_Integer
    val%int_val = int_val
  end function int_value

  elemental function str_value (str_val) result (val)
    character(*, kind = ck), intent(in) :: str_val
    type(value_t) :: val

    val%tag = v_String
    allocate (val%str_val, source = str_val)
  end function str_value

  subroutine variable_table_t_initialize (vartab, symtab)
    class(variable_table_t), intent(inout) :: vartab
    type(symbol_table_t), intent(in) :: symtab

    allocate (vartab%vals(1:symtab%length()), source = nil_value)
  end subroutine variable_table_t_initialize

  recursive subroutine interpret_ast_node (outp, ast, symtab, vartab, address, retval)
    integer, intent(in) :: outp
    type(interpreter_ast_t), intent(in) :: ast
    type(symbol_table_t), intent(in) :: symtab
    type(variable_table_t), intent(inout) :: vartab
    integer(kind = nk) :: address
    type(value_t), intent(inout) :: retval

    integer(kind = rik) :: variable_index
    type(value_t) :: val1, val2, val3

    select case (ast%nodes(address)%node_variety)

    case (node_Nil)
       retval = nil_value

    case (node_Integer)
       retval = int_value (ast%nodes(address)%int)

    case (node_Identifier)
       variable_index = ast%nodes(address)%int
       retval = vartab%vals(variable_index)

    case (node_String)
       retval = str_value (ast%nodes(address)%str)

    case (node_Assign)
       call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val1)
       variable_index = ast%nodes(left_branch (address))%int
       vartab%vals(variable_index) = val1
       retval = nil_value
       
    case (node_Multiply)
       call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
       call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
       call multiply (val1, val2, val3)
       retval = val3

    case (node_Divide)
       call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
       call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
       call divide (val1, val2, val3)
       retval = val3

    case (node_Mod)
       call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
       call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
       call pseudo_remainder (val1, val2, val3)
       retval = val3

    case (node_Add)
       call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
       call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
       call add (val1, val2, val3)
       retval = val3

    case (node_Subtract)
       call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
       call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
       call subtract (val1, val2, val3)
       retval = val3

    case (node_Less)
       call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
       call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
       call less_than (val1, val2, val3)
       retval = val3

    case (node_LessEqual)
       call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
       call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
       call less_than_or_equal_to (val1, val2, val3)
       retval = val3

    case (node_Greater)
       call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
       call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
       call greater_than (val1, val2, val3)
       retval = val3

    case (node_GreaterEqual)
       call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
       call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
       call greater_than_or_equal_to (val1, val2, val3)
       retval = val3

    case (node_Equal)
       call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
       call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
       call equal_to (val1, val2, val3)
       retval = val3

    case (node_NotEqual)
       call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
       call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
       call not_equal_to (val1, val2, val3)
       retval = val3

    case (node_Negate)
      call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
      retval = int_value (-(rik_cast (val1, ck_'unary ''-''')))

    case (node_Not)
      call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
      retval = int_value (bool2int (rik_cast (val1, ck_'unary ''!''') == 0_rik))

    case (node_And)
      ! For similarity to C, we make this a ‘short-circuiting AND’,
      ! which is really a branching construct rather than a binary
      ! operation.
      call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
      if (rik_cast (val1, ck_'''&&''') == 0_rik) then
         retval = int_value (0_rik)
      else
         call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
         retval = int_value (bool2int (rik_cast (val2, ck_'''&&''') /= 0_rik))
      end if

    case (node_Or)
      ! For similarity to C, we make this a ‘short-circuiting OR’,
      ! which is really a branching construct rather than a binary
      ! operation.
      call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
      if (rik_cast (val1, ck_'''||''') /= 0_rik) then
         retval = int_value (1_rik)
      else
         call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
         retval = int_value (bool2int (rik_cast (val2, ck_'''||''') /= 0_rik))
      end if

    case (node_If)
      call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
      if (rik_cast (val1, ck_'''if-else'' construct') /= 0_rik) then
         call interpret_ast_node (outp, ast, symtab, vartab, &
              &                   left_branch (right_branch (address)), &
              &                   val2)
      else
         call interpret_ast_node (outp, ast, symtab, vartab, &
              &                   right_branch (right_branch (address)), &
              &                   val2)
      end if
      retval = nil_value

    case (node_While)
      call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
      do while (rik_cast (val1, ck_'''while'' construct') /= 0_rik)
         call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
         call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
      end do
      retval = nil_value

    case (node_Prtc)
      call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
      write (outp, '(A1)', advance = 'no') &
           &    char (rik_cast (val1, ck_'''putc'''), kind = ck)
      retval = nil_value

    case (node_Prti, node_Prts)
      call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
      select case (val1%tag)
      case (v_Integer)
         write (outp, '(I0)', advance = 'no') val1%int_val
      case (v_String)
         write (outp, '(A)', advance = 'no') val1%str_val
      case (v_Nil)
         write (outp, '("(no value)")', advance = 'no')
      case default
         error stop
      end select
      retval = nil_value

    case (node_Sequence)
       call interpret_ast_node (outp, ast, symtab, vartab, left_branch (address), val1)
       call interpret_ast_node (outp, ast, symtab, vartab, right_branch (address), val2)
       retval = nil_value

    case default
       write (error_unit, '("unknown node type")')
       stop 1

    end select

  contains

    elemental function left_branch (here_addr) result (left_addr)
      integer(kind = nk), intent(in) :: here_addr
      integer(kind = nk) :: left_addr

      left_addr = here_addr + 1
    end function left_branch

    elemental function right_branch (here_addr) result (right_addr)
      integer(kind = nk), intent(in) :: here_addr
      integer(kind = nk) :: right_addr

      right_addr = here_addr + 1 + ast%nodes(here_addr)%right_branch_offset
    end function right_branch

  end subroutine interpret_ast_node

  subroutine multiply (x, y, z)
    type(value_t), intent(in) :: x, y
    type(value_t), intent(out) :: z

    character(*, kind = ck), parameter :: op = ck_'*'

    z = int_value (rik_cast (x, op) * rik_cast (y, op))
  end subroutine multiply

  subroutine divide (x, y, z)
    type(value_t), intent(in) :: x, y
    type(value_t), intent(out) :: z

    character(*, kind = ck), parameter :: op = ck_'/'

    ! Fortran integer division truncates towards zero, as C’s does.
    z = int_value (rik_cast (x, op) / rik_cast (y, op))
  end subroutine divide

  subroutine pseudo_remainder (x, y, z)
    type(value_t), intent(in) :: x, y
    type(value_t), intent(out) :: z

    !
    ! I call this ‘pseudo-remainder’ because I consider ‘remainder’ to
    ! mean the *non-negative* remainder in A = (B * Quotient) +
    ! Remainder. See https://doi.org/10.1145%2F128861.128862
    !
    ! The pseudo-remainder gives the actual remainder, if both
    ! operands are positive.
    !

    character(*, kind = ck), parameter :: op = ck_'binary ''%'''

    ! Fortran’s MOD intrinsic, when given integer arguments, works
    ! like C ‘%’.
    z = int_value (mod (rik_cast (x, op), rik_cast (y, op)))
  end subroutine pseudo_remainder

  subroutine add (x, y, z)
    type(value_t), intent(in) :: x, y
    type(value_t), intent(out) :: z

    character(*, kind = ck), parameter :: op = ck_'binary ''+'''

    z = int_value (rik_cast (x, op) + rik_cast (y, op))
  end subroutine add

  subroutine subtract (x, y, z)
    type(value_t), intent(in) :: x, y
    type(value_t), intent(out) :: z

    character(*, kind = ck), parameter :: op = ck_'binary ''-'''

    z = int_value (rik_cast (x, op) - rik_cast (y, op))
  end subroutine subtract

  subroutine less_than (x, y, z)
    type(value_t), intent(in) :: x, y
    type(value_t), intent(out) :: z

    character(*, kind = ck), parameter :: op = ck_'binary ''<'''

    z = int_value (bool2int (rik_cast (x, op) < rik_cast (y, op)))
  end subroutine less_than

  subroutine less_than_or_equal_to (x, y, z)
    type(value_t), intent(in) :: x, y
    type(value_t), intent(out) :: z

    character(*, kind = ck), parameter :: op = ck_'binary ''<='''

    z = int_value (bool2int (rik_cast (x, op) <= rik_cast (y, op)))
  end subroutine less_than_or_equal_to

  subroutine greater_than (x, y, z)
    type(value_t), intent(in) :: x, y
    type(value_t), intent(out) :: z

    character(*, kind = ck), parameter :: op = ck_'binary ''>'''

    z = int_value (bool2int (rik_cast (x, op) > rik_cast (y, op)))
  end subroutine greater_than

  subroutine greater_than_or_equal_to (x, y, z)
    type(value_t), intent(in) :: x, y
    type(value_t), intent(out) :: z

    character(*, kind = ck), parameter :: op = ck_'binary ''>='''

    z = int_value (bool2int (rik_cast (x, op) >= rik_cast (y, op)))
  end subroutine greater_than_or_equal_to

  subroutine equal_to (x, y, z)
    type(value_t), intent(in) :: x, y
    type(value_t), intent(out) :: z

    character(*, kind = ck), parameter :: op = ck_'binary ''=='''

    z = int_value (bool2int (rik_cast (x, op) == rik_cast (y, op)))
  end subroutine equal_to

  subroutine not_equal_to (x, y, z)
    type(value_t), intent(in) :: x, y
    type(value_t), intent(out) :: z

    character(*, kind = ck), parameter :: op = ck_'binary ''!='''

    z = int_value (bool2int (rik_cast (x, op) /= rik_cast (y, op)))
  end subroutine not_equal_to

  function rik_cast (val, operation_name) result (i_val)
    class(*), intent(in) :: val
    character(*, kind = ck), intent(in) :: operation_name
    integer(kind = rik) :: i_val

    select type (val)
    class is (value_t)
       if (val%tag == v_Integer) then
          i_val = val%int_val
       else
          call type_error (operation_name)
       end if
    type is (integer(kind = rik))
       i_val = val
    class default
       call type_error (operation_name)
    end select
  end function rik_cast

  elemental function bool2int (bool) result (int)
    logical, intent(in) :: bool
    integer(kind = rik) :: int

    if (bool) then
       int = 1_rik
    else
       int = 0_rik
    end if
  end function bool2int

  subroutine type_error (operation_name)
    character(*, kind = ck), intent(in) :: operation_name

    write (error_unit, '("type error in ", A)') operation_name
    stop 1
  end subroutine type_error

end module ast_interpreter

program Interp
  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
  use, non_intrinsic :: string_buffers
  use, non_intrinsic :: ast_reader
  use, non_intrinsic :: ast_interpreter

  implicit none

  integer, parameter :: inp_unit_no = 100
  integer, parameter :: outp_unit_no = 101

  integer :: arg_count
  character(200) :: arg
  integer :: inp
  integer :: outp

  type(strbuf_t) :: strbuf
  type(interpreter_ast_t) :: ast
  type(symbol_table_t) :: symtab
  type(variable_table_t) :: vartab
  type(value_t) :: retval

  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

     call read_ast (inp, strbuf, ast, symtab)
     if (1 <= ubound (ast%nodes, 1)) then
        call vartab%initialize(symtab)
        call interpret_ast_node (outp, ast, symtab, vartab, 1_nk, retval)
     end if
  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 Interp
Output:

$ ./lex compiler-tests/primes.t | ./parse | ./Interp

3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26

Go[edit]

Translation of: C
package main

import (
    "bufio"
    "fmt"
    "log"
    "os"
    "strconv"
    "strings"
)

type NodeType int

const (
    ndIdent NodeType = iota
    ndString
    ndInteger
    ndSequence
    ndIf
    ndPrtc
    ndPrts
    ndPrti
    ndWhile
    ndAssign
    ndNegate
    ndNot
    ndMul
    ndDiv
    ndMod
    ndAdd
    ndSub
    ndLss
    ndLeq
    ndGtr
    ndGeq
    ndEql
    ndNeq
    ndAnd
    ndOr
)

type Tree struct {
    nodeType NodeType
    left     *Tree
    right    *Tree
    value    int
}

// dependency: Ordered by NodeType, must remain in same order as NodeType enum
type atr struct {
    enumText string
    nodeType NodeType
}

var atrs = []atr{
    {"Identifier", ndIdent},
    {"String", ndString},
    {"Integer", ndInteger},
    {"Sequence", ndSequence},
    {"If", ndIf},
    {"Prtc", ndPrtc},
    {"Prts", ndPrts},
    {"Prti", ndPrti},
    {"While", ndWhile},
    {"Assign", ndAssign},
    {"Negate", ndNegate},
    {"Not", ndNot},
    {"Multiply", ndMul},
    {"Divide", ndDiv},
    {"Mod", ndMod},
    {"Add", ndAdd},
    {"Subtract", ndSub},
    {"Less", ndLss},
    {"LessEqual", ndLeq},
    {"Greater", ndGtr},
    {"GreaterEqual", ndGeq},
    {"Equal", ndEql},
    {"NotEqual", ndNeq},
    {"And", ndAnd},
    {"Or", ndOr},
}

var (
    stringPool   []string
    globalNames  []string
    globalValues = make(map[int]int)
)

var (
    err     error
    scanner *bufio.Scanner
)

func reportError(msg string) {
    log.Fatalf("error : %s\n", msg)
}

func check(err error) {
    if err != nil {
        log.Fatal(err)
    }
}

func btoi(b bool) int {
    if b {
        return 1
    }
    return 0
}

func itob(i int) bool {
    if i == 0 {
        return false
    }
    return true
}

func makeNode(nodeType NodeType, left *Tree, right *Tree) *Tree {
    return &Tree{nodeType, left, right, 0}
}

func makeLeaf(nodeType NodeType, value int) *Tree {
    return &Tree{nodeType, nil, nil, value}
}

func interp(x *Tree) int { // interpret the parse tree
    if x == nil {
        return 0
    }
    switch x.nodeType {
    case ndInteger:
        return x.value
    case ndIdent:
        return globalValues[x.value]
    case ndString:
        return x.value
    case ndAssign:
        n := interp(x.right)
        globalValues[x.left.value] = n
        return n
    case ndAdd:
        return interp(x.left) + interp(x.right)
    case ndSub:
        return interp(x.left) - interp(x.right)
    case ndMul:
        return interp(x.left) * interp(x.right)
    case ndDiv:
        return interp(x.left) / interp(x.right)
    case ndMod:
        return interp(x.left) % interp(x.right)
    case ndLss:
        return btoi(interp(x.left) < interp(x.right))
    case ndGtr:
        return btoi(interp(x.left) > interp(x.right))
    case ndLeq:
        return btoi(interp(x.left) <= interp(x.right))
    case ndEql:
        return btoi(interp(x.left) == interp(x.right))
    case ndNeq:
        return btoi(interp(x.left) != interp(x.right))
    case ndAnd:
        return btoi(itob(interp(x.left)) && itob(interp(x.right)))
    case ndOr:
        return btoi(itob(interp(x.left)) || itob(interp(x.right)))
    case ndNegate:
        return -interp(x.left)
    case ndNot:
        if interp(x.left) == 0 {
            return 1
        }
        return 0
    case ndIf:
        if interp(x.left) != 0 {
            interp(x.right.left)
        } else {
            interp(x.right.right)
        }
        return 0
    case ndWhile:
        for interp(x.left) != 0 {
            interp(x.right)
        }
        return 0
    case ndPrtc:
        fmt.Printf("%c", interp(x.left))
        return 0
    case ndPrti:
        fmt.Printf("%d", interp(x.left))
        return 0
    case ndPrts:
        fmt.Print(stringPool[interp(x.left)])
        return 0
    case ndSequence:
        interp(x.left)
        interp(x.right)
        return 0
    default:
        reportError(fmt.Sprintf("interp: unknown tree type %d\n", x.nodeType))
    }
    return 0
}

func getEnumValue(name string) NodeType {
    for _, atr := range atrs {
        if atr.enumText == name {
            return atr.nodeType
        }
    }
    reportError(fmt.Sprintf("Unknown token %s\n", name))
    return -1
}

func fetchStringOffset(s string) int {
    var d strings.Builder
    s = s[1 : len(s)-1]
    for i := 0; i < len(s); i++ {
        if s[i] == '\\' && (i+1) < len(s) {
            if s[i+1] == 'n' {
                d.WriteByte('\n')
                i++
            } else if s[i+1] == '\\' {
                d.WriteByte('\\')
                i++
            }
        } else {
            d.WriteByte(s[i])
        }
    }
    s = d.String()
    for i := 0; i < len(stringPool); i++ {
        if s == stringPool[i] {
            return i
        }
    }
    stringPool = append(stringPool, s)
    return len(stringPool) - 1
}

func fetchVarOffset(name string) int {
    for i := 0; i < len(globalNames); i++ {
        if globalNames[i] == name {
            return i
        }
    }
    globalNames = append(globalNames, name)
    return len(globalNames) - 1
}

func loadAst() *Tree {
    var nodeType NodeType
    var s string
    if scanner.Scan() {
        line := strings.TrimRight(scanner.Text(), " \t")
        tokens := strings.Fields(line)
        first := tokens[0]
        if first[0] == ';' {
            return nil
        }
        nodeType = getEnumValue(first)
        le := len(tokens)
        if le == 2 {
            s = tokens[1]
        } else if le > 2 {
            idx := strings.Index(line, `"`)
            s = line[idx:]
        }
    }
    check(scanner.Err())
    if s != "" {
        var n int
        switch nodeType {
        case ndIdent:
            n = fetchVarOffset(s)
        case ndInteger:
            n, err = strconv.Atoi(s)
            check(err)
        case ndString:
            n = fetchStringOffset(s)
        default:
            reportError(fmt.Sprintf("Unknown node type: %s\n", s))
        }
        return makeLeaf(nodeType, n)
    }    
    left := loadAst()
    right := loadAst()
    return makeNode(nodeType, left, right)
}

func main() {
    ast, err := os.Open("ast.txt")
    check(err)
    defer ast.Close()
    scanner = bufio.NewScanner(ast)
    x := loadAst()
    interp(x)
}
Output:

Prime Numbers example:

3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26

J[edit]

Implementation:

outbuf=: ''
emit=:{{
  outbuf=: outbuf,y
  if.LF e. outbuf do.
    ndx=. outbuf i:LF
    echo ndx{.outbuf
    outbuf=: }.ndx}.outbuf
  end.
}}

load_ast=: {{
  'node_types node_values'=: 2{.|:(({.,&<&<}.@}.)~ i.&' ');._2 y
  1{::0 load_ast ''
:
  node_type=. x{::node_types
  if. node_type-:,';' do. x;a: return.end.
  node_value=. x{::node_values
  if. -.''-:node_value do.x;<node_type make_leaf node_value return.end.
  'x left'=.(x+1) load_ast''
  'x right'=.(x+1) load_ast''
  x;<node_type make_node left right
}}

make_leaf=: ; 
typ=: 0&{::
val=: left=: 1&{::
right=: 2&{::
make_node=: {{m;n;<y}}
id2var=: 'var_',rplc&('z';'zz';'_';'_z')

interp=:{{
  if.y-:'' do.'' return.end.
  V=. val y
  W=. ;2}.y
  select.typ y
    case.'Integer'do._".V
    case.'String'do.rplc&('\\';'\';'\n';LF) V-.'"'
    case.'Identifier'do.".id2var V
    case.'Assign'do.''[(id2var left V)=: interp W
    case.'Multiply'do.V *&interp W
    case.'Divide'do.V (*&* * <.@%&|)&interp W
    case.'Mod'do.V (*&* * |~&|)&interp W
    case.'Add'do.V +&interp W
    case.'Subtract'do.V -&interp W
    case.'Negate'do.-interp V
    case.'Less'do.V <&interp W
    case.'LessEqual'do.V <:&interp W
    case.'Greater'do.V >&interp W
    case.'GreaterEqual'do.V >&interp W
    case.'Equal'do.V =&interp W
    case.'NotEqual'do.V ~:&interp W
    case.'Not'do.0=interp V
    case.'And'do.V *.&interp W
    case.'Or' do.V +.&interp W
    case.'If'do.if.interp V do.interp left W else.interp right W end.''
    case.'While'do.while.interp V do.interp W end.''
    case.'Prtc'do.emit u:interp V
    case.'Prti'do.emit rplc&'_-'":interp V
    case.'Prts'do.emit interp V
    case.'Sequence'do.
      interp V
      interp W
      ''
    case.do.error'unknown node type ',typ y
  end.
}}

Task example:

primes=:{{)n
/*
 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"); 
}}

  ast_interp syntax lex primes
3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26

Java[edit]

import java.util.Scanner;
import java.io.File;
import java.util.List;
import java.util.ArrayList;
import java.util.Map;
import java.util.HashMap;

class Interpreter {
	static Map<String, Integer> globals = new HashMap<>();
	static Scanner s;
	static List<Node> list = new ArrayList<>();
	static Map<String, NodeType> str_to_nodes = new HashMap<>();

	static class Node {
		public NodeType nt;
		public Node left, right;
		public String value;
		
		Node() {
			this.nt = null;
			this.left = null;
			this.right = null;
			this.value = null;
		}
		Node(NodeType node_type, Node left, Node right, String value) {
			this.nt = node_type;
			this.left = left;
			this.right = right;
			this.value = value;
		}
		public static Node make_node(NodeType nodetype, Node left, Node right) {
			return new Node(nodetype, left, right, "");
		}
		public static Node make_node(NodeType nodetype, Node left) {
			return new Node(nodetype, left, null, "");
		}
		public static Node make_leaf(NodeType nodetype, String value) {
			return new Node(nodetype, null, null, value);
		}
	}
	static enum NodeType {
		nd_None(";"), nd_Ident("Identifier"), nd_String("String"), nd_Integer("Integer"),
		nd_Sequence("Sequence"), nd_If("If"),
		nd_Prtc("Prtc"), nd_Prts("Prts"), nd_Prti("Prti"), nd_While("While"),
		nd_Assign("Assign"), nd_Negate("Negate"), nd_Not("Not"), nd_Mul("Multiply"), nd_Div("Divide"),
		nd_Mod("Mod"), nd_Add("Add"),
		nd_Sub("Subtract"), nd_Lss("Less"), nd_Leq("LessEqual"),
		nd_Gtr("Greater"), nd_Geq("GreaterEqual"), nd_Eql("Equal"), nd_Neq("NotEqual"), nd_And("And"), nd_Or("Or");
		
		private final String name;
		
		NodeType(String name) {	this.name = name; }
		
		@Override
		public String toString() { return this.name; }
	}
	static String str(String s) {
		String result = "";
		int i = 0;
		s = s.replace("\"", "");
		while (i < s.length()) {
			if (s.charAt(i) == '\\' && i + 1 < s.length()) {
				if (s.charAt(i + 1) == 'n') {
					result += '\n';
					i += 2;
				} else if (s.charAt(i) == '\\') {
					result += '\\';
					i += 2;
				} 
			} else {
				result += s.charAt(i);
				i++;
			}
		}
		return result;
	}
	static boolean itob(int i) {
		return i != 0;
	}
	static int btoi(boolean b) {
		return b ? 1 : 0;
	}
	static int fetch_var(String name) {
		int result;
		if (globals.containsKey(name)) {
			result = globals.get(name);
		} else {
			globals.put(name, 0);
			result = 0;
		}
		return result;		
	}
	static Integer interpret(Node n) throws Exception {
		if (n == null) {
			return 0;
		}
		switch (n.nt) {
			case nd_Integer:
				return Integer.parseInt(n.value);
			case nd_Ident:
				return fetch_var(n.value);
			case nd_String:
				return 1;//n.value;
			case nd_Assign:
				globals.put(n.left.value, interpret(n.right));
				return 0;
			case nd_Add:
				return interpret(n.left) + interpret(n.right);
			case nd_Sub:
				return interpret(n.left) - interpret(n.right);
			case nd_Mul:
				return interpret(n.left) * interpret(n.right);
			case nd_Div:
				return interpret(n.left) / interpret(n.right);
			case nd_Mod:
				return interpret(n.left) % interpret(n.right);
			case nd_Lss:
				return btoi(interpret(n.left) < interpret(n.right));
			case nd_Leq:
				return btoi(interpret(n.left) <= interpret(n.right));
			case nd_Gtr:
				return btoi(interpret(n.left) > interpret(n.right));
			case nd_Geq:
				return btoi(interpret(n.left) >= interpret(n.right));
			case nd_Eql:
				return btoi(interpret(n.left) == interpret(n.right));
			case nd_Neq:
				return btoi(interpret(n.left) != interpret(n.right));
			case nd_And:
				return btoi(itob(interpret(n.left)) && itob(interpret(n.right)));
			case nd_Or:
				return btoi(itob(interpret(n.left)) || itob(interpret(n.right)));
			case nd_Not:
				if (interpret(n.left) == 0) {
					return 1;
				} else {
					return 0;
				}
			case nd_Negate:
				return -interpret(n.left);
			case nd_If:
				if (interpret(n.left) != 0) {
					interpret(n.right.left);
				} else {
					interpret(n.right.right);
				}
				return 0;
			case nd_While:
				while (interpret(n.left) != 0) {
					interpret(n.right);
				}
				return 0;
			case nd_Prtc:
				System.out.printf("%c", interpret(n.left));
				return 0;
			case nd_Prti:
				System.out.printf("%d", interpret(n.left));
				return 0;
			case nd_Prts:
				System.out.print(str(n.left.value));//interpret(n.left));
				return 0;
			case nd_Sequence:
				interpret(n.left);
				interpret(n.right);
				return 0;
			default:
				throw new Exception("Error: '" + n.nt + "' found, expecting operator");
		}
	}
	static Node load_ast() throws Exception {
		String command, value;
		String line;
		Node left, right;
		
		while (s.hasNext()) {
			line = s.nextLine();
			value = null;
			if (line.length() > 16) {
				command = line.substring(0, 15).trim();
				value = line.substring(15).trim();
			} else {
				command = line.trim();
			}
			if (command.equals(";")) {
				return null;
			}
			if (!str_to_nodes.containsKey(command)) {
				throw new Exception("Command not found: '" + command + "'");
			}
			if (value != null) {
				return Node.make_leaf(str_to_nodes.get(command), value);
			}
			left = load_ast(); right = load_ast();
			return Node.make_node(str_to_nodes.get(command), left, right);
		}
		return null; // for the compiler, not needed
	}
	public static void main(String[] args) {
		Node n;

		str_to_nodes.put(";", NodeType.nd_None);
		str_to_nodes.put("Sequence", NodeType.nd_Sequence);
		str_to_nodes.put("Identifier", NodeType.nd_Ident);
		str_to_nodes.put("String", NodeType.nd_String);
		str_to_nodes.put("Integer", NodeType.nd_Integer);
		str_to_nodes.put("If", NodeType.nd_If);
		str_to_nodes.put("While", NodeType.nd_While);
		str_to_nodes.put("Prtc", NodeType.nd_Prtc);
		str_to_nodes.put("Prts", NodeType.nd_Prts);
		str_to_nodes.put("Prti", NodeType.nd_Prti);
		str_to_nodes.put("Assign", NodeType.nd_Assign);
		str_to_nodes.put("Negate", NodeType.nd_Negate);
		str_to_nodes.put("Not", NodeType.nd_Not);
		str_to_nodes.put("Multiply", NodeType.nd_Mul);
		str_to_nodes.put("Divide", NodeType.nd_Div);
		str_to_nodes.put("Mod", NodeType.nd_Mod);
		str_to_nodes.put("Add", NodeType.nd_Add);
		str_to_nodes.put("Subtract", NodeType.nd_Sub);
		str_to_nodes.put("Less", NodeType.nd_Lss);
		str_to_nodes.put("LessEqual", NodeType.nd_Leq);
		str_to_nodes.put("Greater", NodeType.nd_Gtr);
		str_to_nodes.put("GreaterEqual", NodeType.nd_Geq);
		str_to_nodes.put("Equal", NodeType.nd_Eql);
		str_to_nodes.put("NotEqual", NodeType.nd_Neq);
		str_to_nodes.put("And", NodeType.nd_And);
		str_to_nodes.put("Or", NodeType.nd_Or);
		
		if (args.length > 0) {
			try {
				s = new Scanner(new File(args[0]));
				n = load_ast();
				interpret(n);
			} catch (Exception e) {
				System.out.println("Ex: "+e.getMessage());
			}
		}
	}
}

Julia[edit]

struct Anode
    node_type::String
    left::Union{Nothing, Anode}
    right::Union{Nothing, Anode}
    value::Union{Nothing, String}
end

make_leaf(t, v) = Anode(t, nothing, nothing, v)
make_node(t, l, r) = Anode(t, l, r, nothing)

const OP2 = Dict("Multiply" => "*", "Divide" => "/", "Mod" => "%", "Add" => "+", "Subtract" => "-", 
                 "Less" => "<", "Greater" => ">", "LessEqual" => "<=", "GreaterEqual" => ">=", 
                 "Equal" => "==", "NotEqual" => "!=", "And" => "&&", "Or" => "||")
const OP1 = Dict("Not" => "!", "Minus" => "-")

tobool(i::Bool) = i
tobool(i::Int) = (i != 0)
tobool(s::String) = eval(Symbol(s)) != 0

const stac = Vector{Any}()

function call2(op, x, y)
    if op in ["And", "Or"]
        x, y = tobool(x), tobool(y)
    end
    eval(Meta.parse("push!(stac, $(x) $(OP2[op]) $(y))"))
    return Int(floor(pop!(stac)))
end

call1(op, x) = (if op in ["Not"] x = tobool(x) end; eval(Meta.parse("$(OP1[op]) $(x)")))
evalpn(op, x, y = nothing) = (haskey(OP2, op) ? call2(op, x, y) : call1(op, x))

function load_ast(io)
    line = strip(readline(io))
    line_list = filter(x -> x != nothing, match(r"(?:(\w+)\s+(\d+|\w+|\".*\")|(\w+|;))", line).captures)
    text = line_list[1]
    if text == ";"
        return nothing
    end
    node_type = text
    if length(line_list) > 1
        return make_leaf(line_list[1], line_list[2])
    end
    left = load_ast(io)
    right = load_ast(io)
    return make_node(line_list[1], left, right)
end

function interp(x)
    if x == nothing return nothing
    elseif x.node_type == "Integer" return parse(Int, x.value)
    elseif x.node_type == "Identifier" return "_" * x.value
    elseif x.node_type == "String" return replace(replace(x.value, "\"" => ""), "\\n" => "\n")
    elseif x.node_type == "Assign" s = "$(interp(x.left)) = $(interp(x.right))"; eval(Meta.parse(s)); return nothing
    elseif x.node_type in keys(OP2) return evalpn(x.node_type, interp(x.left), interp(x.right))
    elseif x.node_type in keys(OP1) return evalpn(x.node_type, interp(x.left))
    elseif x.node_type ==  "If" tobool(eval(interp(x.left))) ? interp(x.right.left) : interp(x.right.right); return nothing
    elseif x.node_type == "While" while tobool(eval(interp(x.left))) interp(x.right) end; return nothing
    elseif x.node_type == "Prtc" print(Char(eval(interp(x.left)))); return nothing
    elseif x.node_type == "Prti" s = interp(x.left); print((i = tryparse(Int, s)) == nothing ? eval(Symbol(s)) : i); return nothing
    elseif x.node_type == "Prts" print(eval(interp(x.left))); return nothing
    elseif x.node_type == "Sequence" interp(x.left); interp(x.right); return nothing
    else
        throw("unknown node type: $x")
    end
end

const testparsed = """
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\"
;  """

const lio = IOBuffer(testparsed)

interp(load_ast(lio))
Output:

3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26

Nim[edit]

Using AST produced by the parser from the task “syntax analyzer”.

import os, strutils, streams, tables

import ast_parser

type

  ValueKind = enum valNil, valInt, valString

  # Representation of a value.
  Value = object
    case kind: ValueKind
    of valNil: nil
    of valInt: intVal: int
    of valString: stringVal: string

  # Range of binary operators.
  BinaryOperator = range[nMultiply..nOr]

# Table of variables.
var variables: Table[string, Value]

type RunTimeError = object of CatchableError

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

template newInt(val: typed): Value =
  ## Create an integer value.
  Value(kind: valInt, intVal: val)

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

proc interp(node: Node): Value =
  ## Interpret code starting at "node".

  if node.isNil:
    return Value(kind: valNil)

  case node.kind

  of nInteger:
    result = Value(kind: valInt, intVal: node.intVal)

  of nIdentifier:
    if node.name notin variables:
      raise newException(RunTimeError, "Variable {node.name} is not initialized.")
    result = variables[node.name]

  of nString:
    result = Value(kind: valString, stringVal: node.stringVal)

  of nAssign:
    variables[node.left.name] = interp(node.right)

  of nNegate:
    result = newInt(-interp(node.left).intVal)

  of nNot:
    result = newInt(not interp(node.left).intVal)

  of BinaryOperator.low..BinaryOperator.high:

    let left = interp(node.left)
    let right = interp(node.right)

    case BinaryOperator(node.kind)
    of nMultiply:
      result = newInt(left.intVal * right.intVal)
    of nDivide:
      result = newInt(left.intVal div right.intVal)
    of nMod:
      result = newInt(left.intVal mod right.intVal)
    of nAdd:
      result = newInt(left.intVal + right.intVal)
    of nSubtract:
      result = newInt(left.intVal - right.intVal)
    of nLess:
      result = newInt(ord(left.intVal < right.intVal))
    of nLessEqual:
      result = newInt(ord(left.intVal <= right.intVal))
    of nGreater:
      result = newInt(ord(left.intVal > right.intVal))
    of nGreaterEqual:
      result = newInt(ord(left.intVal >= right.intVal))
    of nEqual:
      result = newInt(ord(left.intVal == right.intVal))
    of nNotEqual:
      result = newInt(ord(left.intVal != right.intVal))
    of nAnd:
      result = newInt(left.intVal and right.intVal)
    of nOr:
      result = newInt(left.intVal or right.intVal)

  of nIf:
    if interp(node.left).intVal != 0:
      discard interp(node.right.left)
    else:
      discard interp(node.right.right)

  of nWhile:
    while interp(node.left).intVal != 0:
      discard interp(node.right)

  of nPrtc:
    stdout.write(chr(interp(node.left).intVal))

  of nPrti:
    stdout.write(interp(node.left).intVal)

  of nPrts:
    stdout.write(interp(node.left).stringVal)

  of nSequence:
    discard interp(node.left)
    discard interp(node.right)

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

import re

proc loadAst(stream: Stream): Node =
  ## Load a linear AST and build a binary tree.

  let line = stream.readLine().strip()
  if line.startsWith(';'):
    return nil

  var fields = line.split(' ', 1)
  let kind = parseEnum[NodeKind](fields[0])
  if kind in {nIdentifier, nString, nInteger}:
    if fields.len < 2:
      raise newException(ValueError, "Missing value field for " & fields[0])
    else:
      fields[1] = fields[1].strip()
  case kind
  of nIdentifier:
    return Node(kind: nIdentifier, name: fields[1])
  of nString:
    str = fields[1].replacef(re"([^\\])(\\n)", "$1\n").replace(r"\\", r"\").replace("\"", "")
    return Node(kind: nString, stringVal: str)
  of nInteger:
    return Node(kind: nInteger, intVal: parseInt(fields[1]))
  else:
    if fields.len > 1:
      raise newException(ValueError, "Extra field for " & fields[0])

  let left = stream.loadAst()
  let right = stream.loadAst()
  result = newNode(kind, left, right)

#———————————————————————————————————————————————————————————————————————————————————————————————————

var stream: Stream
var toClose = false

if paramCount() < 1:
  stream = newFileStream(stdin)
else:
  stream = newFileStream(paramStr(1))
  toClose = true

let ast = loadAst(stream)
if toClose: stream.close()

discard ast.interp()
Output:

Output from the program ASCII Mandelbrot: https://rosettacode.org/wiki/Compiler/Sample_programs#Ascii_Mandlebrot

1111111111111111111111122222222222222222222222222222222222222222222222222222222222222222222222222211111
1111111111111111111122222222222222222222222222222222222222222222222222222222222222222222222222222222211
1111111111111111112222222222222222222222222222222222222222222222222222222222222222222222222222222222222
1111111111111111222222222222222222233333333333333333333333222222222222222222222222222222222222222222222
1111111111111112222222222222333333333333333333333333333333333333222222222222222222222222222222222222222
1111111111111222222222233333333333333333333333344444456655544443333332222222222222222222222222222222222
1111111111112222222233333333333333333333333444444445567@@6665444444333333222222222222222222222222222222
11111111111222222333333333333333333333334444444445555679@@@@7654444443333333222222222222222222222222222
1111111112222223333333333333333333333444444444455556789@@@@98755544444433333332222222222222222222222222
1111111122223333333333333333333333344444444445556668@@@    @@@76555544444333333322222222222222222222222
1111111222233333333333333333333344444444455566667778@@      @987666555544433333333222222222222222222222
111111122333333333333333333333444444455556@@@@@99@@@@@@    @@@@@@877779@5443333333322222222222222222222
1111112233333333333333333334444455555556679@   @@@               @@@@@@ 8544333333333222222222222222222
1111122333333333333333334445555555556666789@@@                        @86554433333333322222222222222222
1111123333333333333444456666555556666778@@ @                         @@87655443333333332222222222222222
111123333333344444455568@887789@8777788@@@                            @@@@65444333333332222222222222222
111133334444444455555668@@@@@@@@@@@@99@@@                              @@765444333333333222222222222222
111133444444445555556778@@@         @@@@                                @855444333333333222222222222222
11124444444455555668@99@@             @                                 @655444433333333322222222222222
11134555556666677789@@                                                @86655444433333333322222222222222
111                                                                 @@876555444433333333322222222222222
11134555556666677789@@                                                @86655444433333333322222222222222
11124444444455555668@99@@             @                                 @655444433333333322222222222222
111133444444445555556778@@@         @@@@                                @855444333333333222222222222222
111133334444444455555668@@@@@@@@@@@@99@@@                              @@765444333333333222222222222222
111123333333344444455568@887789@8777788@@@                            @@@@65444333333332222222222222222
1111123333333333333444456666555556666778@@ @                         @@87655443333333332222222222222222
1111122333333333333333334445555555556666789@@@                        @86554433333333322222222222222222
1111112233333333333333333334444455555556679@   @@@               @@@@@@ 8544333333333222222222222222222
111111122333333333333333333333444444455556@@@@@99@@@@@@    @@@@@@877779@5443333333322222222222222222222
1111111222233333333333333333333344444444455566667778@@      @987666555544433333333222222222222222222222
1111111122223333333333333333333333344444444445556668@@@    @@@76555544444333333322222222222222222222222
1111111112222223333333333333333333333444444444455556789@@@@98755544444433333332222222222222222222222222
11111111111222222333333333333333333333334444444445555679@@@@7654444443333333222222222222222222222222222
1111111111112222222233333333333333333333333444444445567@@6665444444333333222222222222222222222222222222
1111111111111222222222233333333333333333333333344444456655544443333332222222222222222222222222222222222
1111111111111112222222222222333333333333333333333333333333333333222222222222222222222222222222222222222
1111111111111111222222222222222222233333333333333333333333222222222222222222222222222222222222222222222
1111111111111111112222222222222222222222222222222222222222222222222222222222222222222222222222222222222
1111111111111111111122222222222222222222222222222222222222222222222222222222222222222222222222222222211

Perl[edit]

Tested with perl v5.26.1

#!/usr/bin/perl

use strict;   # interpreter.pl - execute a flatAST
use warnings; # http://www.rosettacode.org/wiki/Compiler/AST_interpreter
use integer;

my %variables;

tree()->run;

sub tree
  {
  my $line = <> // die "incomplete tree\n";
  (local $_, my $arg) = $line =~ /^(\w+|;)\s+(.*)/ or die "bad input $line";
  /String/ ? bless [$arg =~ tr/""//dr =~ s/\\(.)/$1 eq 'n' ? "\n" : $1/ger], $_ :
    /Identifier|Integer/ ? bless [ $arg ], $_ :
    /;/ ? bless [], 'Null' :
    bless [ tree(), tree() ], $_;
  }

sub Add::run { $_[0][0]->run + $_[0][1]->run }
sub And::run { $_[0][0]->run && $_[0][1]->run }
sub Assign::run { $variables{$_[0][0][0]} = $_[0][1]->run }
sub Divide::run { $_[0][0]->run / $_[0][1]->run }
sub Equal::run { $_[0][0]->run == $_[0][1]->run ? 1 : 0 }
sub Greater::run { $_[0][0]->run > $_[0][1]->run ? 1 : 0 }
sub GreaterEqual::run { $_[0][0]->run >= $_[0][1]->run ? 1 : 0 }
sub Identifier::run { $variables{$_[0][0]} // 0 }
sub If::run { $_[0][0]->run ? $_[0][1][0]->run : $_[0][1][1]->run }
sub Integer::run { $_[0][0] }
sub Less::run { $_[0][0]->run < $_[0][1]->run ? 1 : 0 }
sub LessEqual::run { $_[0][0]->run <= $_[0][1]->run ? 1 : 0 }
sub Mod::run { $_[0][0]->run % $_[0][1]->run }
sub Multiply::run { $_[0][0]->run * $_[0][1]->run }
sub Negate::run { - $_[0][0]->run }
sub Not::run { $_[0][0]->run ? 0 : 1 }
sub NotEqual::run { $_[0][0]->run != $_[0][1]->run ? 1 : 0 }
sub Null::run {}
sub Or::run { $_[0][0]->run || $_[0][1]->run }
sub Prtc::run { print chr $_[0][0]->run }
sub Prti::run { print $_[0][0]->run }
sub Prts::run { print $_[0][0][0] }
sub Sequence::run { $_->run for $_[0]->@* }
sub Subtract::run { $_[0][0]->run - $_[0][1]->run }
sub While::run { $_[0][1]->run while $_[0][0]->run }

Passes all tests.

Phix[edit]

Reusing parse.e from the Syntax Analyzer task

--
-- demo\rosetta\Compiler\interp.exw
-- ================================
--
with javascript_semantics
include parse.e

sequence vars = {},
         vals = {}

function var_idx(sequence inode)
    if inode[1]!=tk_Identifier then ?9/0 end if
    string ident = inode[2]
    integer n = find(ident,vars)
    if n=0 then
        vars = append(vars,ident)
        vals = append(vals,0)
        n = length(vars)
    end if
    return n
end function

function interp(object t)
    if t!=NULL then
        integer ntype = t[1]
        object t2 = t[2], 
               t3 = iff(length(t)=3?t[3]:0)
        switch ntype do
            case tk_Sequence:       {} = interp(t2) {} = interp(t3)
            case tk_assign:         vals[var_idx(t2)] = interp(t3)
            case tk_Identifier:     return vals[var_idx(t)]
            case tk_Integer:        return t2
            case tk_String:         return t2
            case tk_lt:             return interp(t2) < interp(t3)
            case tk_add:            return interp(t2) + interp(t3)
            case tk_sub:            return interp(t2) - interp(t3)
            case tk_while:          while interp(t2) do {} = interp(t3) end while
            case tk_Prints:         puts(1,interp(t2))
            case tk_Printi:         printf(1,"%d",interp(t2))
            case tk_putc:           printf(1,"%c",interp(t2))
            case tk_and:            return interp(t2) and interp(t3)
            case tk_or:             return interp(t2) or interp(t3)
            case tk_le:             return interp(t2) <= interp(t3)
            case tk_ge:             return interp(t2) >= interp(t3)
            case tk_ne:             return interp(t2) != interp(t3)
            case tk_gt:             return interp(t2) > interp(t3)
            case tk_mul:            return interp(t2) * interp(t3)
            case tk_div:            return trunc(interp(t2)/interp(t3))
            case tk_mod:            return remainder(interp(t2),interp(t3))
            case tk_if:             {} = interp(t3[iff(interp(t2)?2:3)])
            case tk_not:            return not interp(t2)
            case tk_neg:            return - interp(t2)
            else
                error("unknown node type")
        end switch
    end if
    return NULL
end function

procedure main(sequence cl)
    open_files(cl)
    toks = lex()
    object t = parse()
    {} = interp(t)
    close_files()
end procedure

--main(command_line())
main({0,0,"primes.c"})
Output:
3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26

Python[edit]

Tested with Python 2.7 and 3.x

from __future__ import print_function
import sys, shlex, operator

nd_Ident, nd_String, nd_Integer, nd_Sequence, nd_If, nd_Prtc, nd_Prts, nd_Prti, nd_While, \
nd_Assign, nd_Negate, nd_Not, nd_Mul, nd_Div, nd_Mod, nd_Add, nd_Sub, nd_Lss, nd_Leq,     \
nd_Gtr, nd_Geq, nd_Eql, nd_Neq, nd_And, nd_Or = range(25)

all_syms = {
    "Identifier"  : nd_Ident,    "String"      : nd_String,
    "Integer"     : nd_Integer,  "Sequence"    : nd_Sequence,
    "If"          : nd_If,       "Prtc"        : nd_Prtc,
    "Prts"        : nd_Prts,     "Prti"        : nd_Prti,
    "While"       : nd_While,    "Assign"      : nd_Assign,
    "Negate"      : nd_Negate,   "Not"         : nd_Not,
    "Multiply"    : nd_Mul,      "Divide"      : nd_Div,
    "Mod"         : nd_Mod,      "Add"         : nd_Add,
    "Subtract"    : nd_Sub,      "Less"        : nd_Lss,
    "LessEqual"   : nd_Leq,      "Greater"     : nd_Gtr,
    "GreaterEqual": nd_Geq,      "Equal"       : nd_Eql,
    "NotEqual"    : nd_Neq,      "And"         : nd_And,
    "Or"          : nd_Or}

input_file  = None
globals     = {}

#*** show error and exit
def error(msg):
    print("%s" % (msg))
    exit(1)

class Node:
    def __init__(self, node_type, left = None, right = None, value = None):
        self.node_type  = node_type
        self.left  = left
        self.right = right
        self.value = value

#***
def make_node(oper, left, right = None):
    return Node(oper, left, right)

#***
def make_leaf(oper, n):
    return Node(oper, value = n)

#***
def fetch_var(var_name):
    n = globals.get(var_name, None)
    if n == None:
        globals[var_name] = n = 0
    return n

#***
def interp(x):
    global globals

    if x == None: return None
    elif x.node_type == nd_Integer: return int(x.value)
    elif x.node_type == nd_Ident:   return fetch_var(x.value)
    elif x.node_type == nd_String:  return x.value

    elif x.node_type == nd_Assign:
                    globals[x.left.value] = interp(x.right)
                    return None
    elif x.node_type == nd_Add:     return interp(x.left) +   interp(x.right)
    elif x.node_type == nd_Sub:     return interp(x.left) -   interp(x.right)
    elif x.node_type == nd_Mul:     return interp(x.left) *   interp(x.right)
    # use C like division semantics
    # another way: abs(x) / abs(y) * cmp(x, 0) * cmp(y, 0)
    elif x.node_type == nd_Div:     return int(float(interp(x.left)) / interp(x.right))
    elif x.node_type == nd_Mod:     return int(float(interp(x.left)) % interp(x.right))
    elif x.node_type == nd_Lss:     return interp(x.left) <   interp(x.right)
    elif x.node_type == nd_Gtr:     return interp(x.left) >   interp(x.right)
    elif x.node_type == nd_Leq:     return interp(x.left) <=  interp(x.right)
    elif x.node_type == nd_Geq:     return interp(x.left) >=  interp(x.right)
    elif x.node_type == nd_Eql:     return interp(x.left) ==  interp(x.right)
    elif x.node_type == nd_Neq:     return interp(x.left) !=  interp(x.right)
    elif x.node_type == nd_And:     return interp(x.left) and interp(x.right)
    elif x.node_type == nd_Or:      return interp(x.left) or  interp(x.right)
    elif x.node_type == nd_Negate:  return -interp(x.left)
    elif x.node_type == nd_Not:     return not interp(x.left)

    elif x.node_type ==  nd_If:
                    if (interp(x.left)):
                        interp(x.right.left)
                    else:
                        interp(x.right.right)
                    return None

    elif x.node_type == nd_While:
                    while (interp(x.left)):
                        interp(x.right)
                    return None

    elif x.node_type == nd_Prtc:
                    print("%c" % (interp(x.left)), end='')
                    return None

    elif x.node_type == nd_Prti:
                    print("%d" % (interp(x.left)), end='')
                    return None

    elif x.node_type == nd_Prts:
                    print(interp(x.left), end='')
                    return None

    elif x.node_type == nd_Sequence:
                    interp(x.left)
                    interp(x.right)
                    return None
    else:
        error("error in code generator - found %d, expecting operator" % (x.node_type))

def str_trans(srce):
    dest = ""
    i = 0
    srce = srce[1:-1]
    while i < len(srce):
        if srce[i] == '\\' and i + 1 < len(srce):
            if srce[i + 1] == 'n':
                dest += '\n'
                i += 2
            elif srce[i + 1] == '\\':
                dest += '\\'
                i += 2
        else:
            dest += srce[i]
            i += 1

    return dest

def load_ast():
    line = input_file.readline()
    line_list = shlex.split(line, False, False)

    text = line_list[0]

    value = None
    if len(line_list) > 1:
        value = line_list[1]
        if value.isdigit():
            value = int(value)

    if text == ";":
        return None
    node_type = all_syms[text]
    if value != None:
        if node_type == nd_String:
            value = str_trans(value)

        return make_leaf(node_type, value)
    left = load_ast()
    right = load_ast()
    return make_node(node_type, left, right)

#*** main driver
input_file = sys.stdin
if len(sys.argv) > 1:
    try:
        input_file = open(sys.argv[1], "r", 4096)
    except IOError as e:
        error(0, 0, "Can't open %s" % sys.argv[1])

n = load_ast()
interp(n)
Output  —  prime numbers output from AST interpreter:

lex prime.t | parse | interp
3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26

RATFOR[edit]

Works with: ratfor77 version public domain 1.0
Works with: gfortran version 11.3.0
Works with: f2c version 20100827


######################################################################
#
# The Rosetta Code AST interpreter in Ratfor 77.
#
#
# In FORTRAN 77 and therefore in Ratfor 77, there is no way to specify
# that a value should be put on a call stack. Therefore there is no
# way to implement recursive algorithms in Ratfor 77 (although see the
# Ratfor for the "syntax analyzer" task, where a recursive language is
# implemented *in* Ratfor). Thus we cannot simply follow the
# recursive pseudocode, and instead use non-recursive algorithms.
#
# How to deal with FORTRAN 77 input is another problem. I use
# formatted input, treating each line as an array of type
# CHARACTER--regrettably of no more than some predetermined, finite
# length. It is a very simple method and presents no significant
# difficulties, aside from the restriction on line length of the
# input.
#
# Output is a bigger problem. If one uses gfortran, "advance='no'" is
# available, but not if one uses f2c. The method employed here is to
# construct the output in lines--regrettably, again, of fixed length.
#
#
# On a POSIX platform, the program can be compiled with f2c and run
# somewhat as follows:
#
#    ratfor77 interp-in-ratfor.r > interp-in-ratfor.f
#    f2c -C -Nc80 interp-in-ratfor.f
#    cc interp-in-ratfor.c -lf2c
#    ./a.out < compiler-tests/primes.ast
#
# With gfortran, a little differently:
#
#    ratfor77 interp-in-ratfor.r > interp-in-ratfor.f
#    gfortran -fcheck=all -std=legacy interp-in-ratfor.f
#    ./a.out < compiler-tests/primes.ast
#
#
# I/O is strictly from default input and to default output, which, on
# POSIX systems, usually correspond respectively to standard input and
# standard output. (I did not wish to have to deal with unit numbers;
# these are now standardized in ISO_FORTRAN_ENV, but that is not
# available in FORTRAN 77.)
#
#---------------------------------------------------------------------

# Some parameters you may wish to modify.

define(LINESZ, 256)           # Size of an input line.
define(OUTLSZ, 1024)          # Size of an output line.
define(STRNSZ, 4096)          # Size of the string pool.
define(NODSSZ, 4096)          # Size of the nodes pool.
define(STCKSZ, 4096)          # Size of stacks.
define(MAXVAR, 256)           # Maximum number of variables.

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

define(NEWLIN, 10)            # The Unix newline character (ASCII LF).
define(DQUOTE, 34)            # The double quote character.
define(BACKSL, 92)            # The backslash character.

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

define(NODESZ, 3)
define(NNEXTF, 1)               # Index for next-free.
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(RGT, 10000)
define(STAGE2, 20000)

# The following all must be less than RGT.
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)

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

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

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

subroutine addstq (strngs, istrng, src, i0, n0, i, n)

  # Add a quoted string to the string pool.

  implicit none

  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character src(*)              # Source string.
  integer i0, n0                # Index and length in source string.
  integer i, n                  # Index and length in string pool.

  integer j
  logical done

1000 format ('attempt to treat an unquoted string as a quoted string')

  if (src(i0) != char (DQUOTE) || src(i0 + n0 - 1) != char (DQUOTE))
    {
      write (*, 1000)
      stop
    }

  i = istrng

  n = 0
  j = i0 + 1
  done = .false.
  while (j != i0 + n0 - 1)
    if (i == STRNSZ)
      {
        write (*, '(''string pool exhausted'')')
        stop
      }
    else if (src(j) == char (BACKSL))
      {
        if (j == i0 + n0 - 1)
          {
            write (*, '(''incorrectly formed quoted string'')')
            stop
          }
        if (src(j + 1) == 'n')
          strngs(istrng) = char (NEWLIN)
        else if (src(j + 1) == char (BACKSL))
          strngs(istrng) = src(j + 1)
        else
          {
            write (*, '(''unrecognized escape sequence'')')
            stop
          }
        istrng = istrng + 1
        n = n + 1
        j = j + 2
      }
    else
      {
        strngs(istrng) = src(j)
        istrng = istrng + 1
        n = n + 1
        j = j + 1
      }
end

subroutine addstu (strngs, istrng, src, i0, n0, i, n)

  # Add an unquoted string to the string pool.

  implicit none

  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character src(*)              # Source string.
  integer i0, n0                # Index and length in source string.
  integer i, n                  # Index and length in string pool.

  integer j

  if (STRNSZ < istrng + (n0 - 1))
    {
      write (*, '(''string pool exhausted'')')
      stop
    }
  for (j = 0; j < n0; j = j + 1)
    strngs(istrng + j) = src(i0 + j)
  i = istrng
  n = n0
  istrng = istrng + n0
end

subroutine addstr (strngs, istrng, src, i0, n0, i, n)

  # Add a string (possibly given as a quoted string) to the string
  # pool.

  implicit none

  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character src(*)              # Source string.
  integer i0, n0                # Index and length in source string.
  integer i, n                  # Index and length in string pool.

  if (n0 == 0)
    {
      i = 0
      n = 0
    }
  else if (src(i0) == char (DQUOTE))
    call addstq (strngs, istrng, src, i0, n0, i, n)
  else
    call addstu (strngs, istrng, src, i0, n0, i, n)
end

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

subroutine push (stack, sp, i)

  implicit none

  integer stack(STCKSZ)
  integer sp                    # Stack pointer.
  integer i                     # Value to push.

  if (sp == STCKSZ)
    {
      write (*, '(''stack overflow in push'')')
      stop
    }
  stack(sp) = i
  sp = sp + 1
end

function pop (stack, sp)

  implicit none

  integer stack(STCKSZ)
  integer sp                    # Stack pointer.
  integer pop

  if (sp == 1)
    {
      write (*, '(''stack underflow in pop'')')
      stop
    }
  sp = sp - 1
  pop = stack(sp)
end

function nstack (sp)

  implicit none

  integer sp                    # Stack pointer.
  integer nstack

  nstack = sp - 1               # Current cardinality of the stack.
end

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

subroutine initnd (nodes, frelst)

  # Initialize the nodes pool.

  implicit none

  integer nodes (NODESZ, NODSSZ)
  integer frelst                # Head of the free list.

  integer i

  for (i = 1; i < NODSSZ; i = i + 1)
    nodes(NNEXTF, i) = i + 1
  nodes(NNEXTF, NODSSZ) = NIL
  frelst = 1
end

subroutine newnod (nodes, frelst, i)

  # Get the index for a new node taken from the free list.

  integer nodes (NODESZ, NODSSZ)
  integer frelst                # Head of the free list.
  integer i                     # Index of the new node.

  integer j

  if (frelst == NIL)
    {
      write (*, '(''nodes pool exhausted'')')
      stop
    }
  i = frelst
  frelst = nodes(NNEXTF, frelst)
  for (j = 1; j <= NODESZ; j = j + 1)
    nodes(j, i) = 0
end

subroutine frenod (nodes, frelst, i)

  # Return a node to the free list.

  integer nodes (NODESZ, NODSSZ)
  integer frelst                # Head of the free list.
  integer i                     # Index of the node to free.

  nodes(NNEXTF, i) = frelst
  frelst = i
end

function strtag (str, i, n)

  implicit none

  character str(*)
  integer i, n
  integer strtag

  character*16 s
  integer j

  for (j = 0; j < 16; j = j + 1)
    if (j < n)
      s(j + 1 : j + 1) = str(i + j)
    else
      s(j + 1 : j + 1) = ' '

  if (s == "Identifier      ")
    strtag = NDID
  else if (s == "String          ")
    strtag = NDSTR
  else if (s == "Integer         ")
    strtag = NDINT
  else if (s == "Sequence        ")
    strtag = NDSEQ
  else if (s == "If              ")
    strtag = NDIF
  else if (s == "Prtc            ")
    strtag = NDPRTC
  else if (s == "Prts            ")
    strtag = NDPRTS
  else if (s == "Prti            ")
    strtag = NDPRTI
  else if (s == "While           ")
    strtag = NDWHIL
  else if (s == "Assign          ")
    strtag = NDASGN
  else if (s == "Negate          ")
    strtag = NDNEG
  else if (s == "Not             ")
    strtag = NDNOT
  else if (s == "Multiply        ")
    strtag = NDMUL
  else if (s == "Divide          ")
    strtag = NDDIV
  else if (s == "Mod             ")
    strtag = NDMOD
  else if (s == "Add             ")
    strtag = NDADD
  else if (s == "Subtract        ")
    strtag = NDSUB
  else if (s == "Less            ")
    strtag = NDLT
  else if (s == "LessEqual       ")
    strtag = NDLE
  else if (s == "Greater         ")
    strtag = NDGT
  else if (s == "GreaterEqual    ")
    strtag = NDGE
  else if (s == "Equal           ")
    strtag = NDEQ
  else if (s == "NotEqual        ")
    strtag = NDNE
  else if (s == "And             ")
    strtag = NDAND
  else if (s == "Or              ")
    strtag = NDOR
  else if (s == ";               ")
    strtag = NIL
  else
    {
      write (*, '(''unrecognized input line: '', A16)') s
      stop
    }
end

subroutine readln (strngs, istrng, tag, iarg, narg)

  # Read a line of the AST input.

  implicit none

  character strngs(STRNSZ) # String pool.
  integer istrng           # String pool's next slot.
  integer tag              # The node tag or NIL.
  integer iarg             # Index of an argument in the string pool.
  integer narg             # Length of an argument in the string pool.

  integer trimrt
  integer strtag
  integer skipsp
  integer skipns

  character line(LINESZ)
  character*20 fmt
  integer i, j, n

  # Read a line of text as an array of characters.
  write (fmt, '(''('', I10, ''A)'')') LINESZ
  read (*, fmt) line

  n = trimrt (line, LINESZ)

  i = skipsp (line, 1, n + 1)
  j = skipns (line, i, n + 1)
  tag = strtag (line, i, j - i)

  i = skipsp (line, j, n + 1)
  call addstr (strngs, istrng, line, i, (n + 1) - i, iarg, narg)
end

function hasarg (tag)

  implicit none

  integer tag
  logical hasarg

  hasarg = (tag == NDID || tag == NDINT || tag == NDSTR)
end

subroutine rdast (strngs, istrng, nodes, frelst, iast)

  # Read in the AST. A non-recursive algorithm is used.

  implicit none

  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer nodes (NODESZ, NODSSZ) # Nodes pool.
  integer frelst                 # Head of the free list.
  integer iast                   # Index of root node of the AST.

  integer nstack
  integer pop
  logical hasarg

  integer stack(STCKSZ)
  integer sp                    # Stack pointer.
  integer tag, iarg, narg
  integer i, j, k

  sp = 1

  call readln (strngs, istrng, tag, iarg, narg)
  if (tag == NIL)
    iast = NIL
  else
    {
      call newnod (nodes, frelst, i)
      iast = i
      nodes(NTAG, i) = tag
      nodes(NITV, i) = 0
      nodes(NITN, i) = 0
      if (hasarg (tag))
        {
          nodes(NITV, i) = iarg
          nodes(NITN, i) = narg
        }
      else
        {
          call push (stack, sp, i + RGT)
          call push (stack, sp, i)
          while (nstack (sp) != 0)
            {
              j = pop (stack, sp)
              k = mod (j, RGT)
              call readln (strngs, istrng, tag, iarg, narg)
              if (tag == NIL)
                i = NIL
              else
                {
                  call newnod (nodes, frelst, i)
                  nodes(NTAG, i) = tag
                  if (hasarg (tag))
                    {
                      nodes(NITV, i) = iarg
                      nodes(NITN, i) = narg
                    }
                  else
                    {
                      call push (stack, sp, i + RGT)
                      call push (stack, sp, i)
                    }
                }
              if (j == k)
                nodes(NLEFT, k) = i
              else
                nodes(NRIGHT, k) = i
            }
        }
    }
end

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

subroutine flushl (outbuf, noutbf)

  # Flush a line from the output buffer.

  implicit none

  character outbuf(OUTLSZ)      # Output line buffer.
  integer noutbf                # Number of characters in outbuf.

  character*20 fmt
  integer i

  if (noutbf == 0)
    write (*, '()')
  else
    {
      write (fmt, 1000) noutbf
1000  format ('(', I10, 'A)')
      write (*, fmt) (outbuf(i), i = 1, noutbf)
      noutbf = 0
    }
end

subroutine wrtchr (outbuf, noutbf, ch)

  # Write a character to output.

  implicit none

  character outbuf(OUTLSZ)      # Output line buffer.
  integer noutbf                # Number of characters in outbuf.
  character ch                  # The character to output.

  # This routine silently truncates anything that goes past the buffer
  # boundary.

  if (ch == char (NEWLIN))
    call flushl (outbuf, noutbf)
  else if (noutbf < OUTLSZ)
    {
      noutbf = noutbf + 1
      outbuf(noutbf) = ch
    }
end

subroutine wrtstr (outbuf, noutbf, str, i, n)

  # Write a substring to output.

  implicit none

  character outbuf(OUTLSZ)      # Output line buffer.
  integer noutbf                # Number of characters in outbuf.
  character str(*)              # The string from which to output.
  integer i, n                  # Index and length of the substring.

  integer j

  for (j = 0; j < n; j = j + 1)
    call wrtchr (outbuf, noutbf, str(i + j))
end

subroutine wrtint (outbuf, noutbf, ival)

  # Write a non-negative integer to output.

  implicit none

  character outbuf(OUTLSZ)      # Output line buffer.
  integer noutbf                # Number of characters in outbuf.
  integer ival                  # The non-negative integer to print.

  integer skipsp

  character*40 buf
  integer i

  # Using "write" probably is the slowest way one could think of to do
  # this, but people do formatted output all the time, anyway. :) The
  # reason, of course, is that output tends to be slow anyway.
  write (buf, '(I40)') ival
  for (i = skipsp (buf, 1, 41); i <= 40; i = i + 1)
    call wrtchr (outbuf, noutbf, buf(i:i))
end

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

define(VARSZ,  3)
define(VNAMEI, 1)          # Variable name's index in the string pool.
define(VNAMEN, 2)          # Length of the name.
define(VVALUE, 3)          # Variable's value.

function fndvar (vars, numvar, strngs, istrng, i0, n0)

  implicit none

  integer vars(VARSZ, MAXVAR)   # Variables.
  integer numvar                # Number of variables.
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  integer i0, n0                # Index and length in the string pool.
  integer fndvar                # The location of the variable.

  integer j, k
  integer i, n
  logical done1
  logical done2

  j = 1
  done1 = .false.
  while (!done1)
    if (j == numvar + 1)
      done1 = .true.
    else if (n0 == vars(VNAMEN, j))
      {
        k = 0
        done2 = .false.
        while (!done2)
          if (n0 <= k)
            done2 = .true.
          else if (strngs(i0 + k) == strngs(vars(VNAMEI, j) + k))
            k = k + 1
          else
            done2 = .true.
        if (k < n0)
          j = j + 1
        else
          {
            done2 = .true.
            done1 = .true.
          }
      }
    else
      j = j + 1

  if (j == numvar + 1)
    {
      if (numvar == MAXVAR)
        {
          write (*, '(''too many variables'')')
          stop
        }
      numvar = numvar + 1
      call addstu (strngs, istrng, strngs, i0, n0, i, n)
      vars(VNAMEI, numvar) = i
      vars(VNAMEN, numvar) = n
      vars(VVALUE, numvar) = 0
      fndvar = numvar
    }
  else
    fndvar = j
end

function strint (strngs, i, n)

  # Convert a string to a non-negative integer.

  implicit none

  character strngs(STRNSZ)       # String pool.
  integer i, n
  integer strint

  integer j

  strint = 0
  for (j = 0; j < n; j = j + 1)
    strint = (10 * strint) + (ichar (strngs(i + j)) - ichar ('0'))
end

function logl2i (u)

  # Convert LOGICAL to INTEGER.

  implicit none

  logical u
  integer logl2i

  if (u)
    logl2i = 1
  else
    logl2i = 0
end

subroutine run (vars, numvar, _
                strngs, istrng, _
                nodes, frelst, _
                outbuf, noutbf, iast)

  # Run (interpret) the AST. The algorithm employed is non-recursive.

  implicit none

  integer vars(VARSZ, MAXVAR)    # Variables.
  integer numvar                 # Number of variables.
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer nodes (NODESZ, NODSSZ) # Nodes pool.
  integer frelst                 # Head of the free list.
  character outbuf(OUTLSZ)       # Output line buffer.
  integer noutbf                 # Number of characters in outbuf.
  integer iast                   # Root node of the AST.

  integer fndvar
  integer logl2i
  integer nstack
  integer pop
  integer strint

  integer dstack(STCKSZ)        # Data stack.
  integer idstck                # Data stack pointer.
  integer xstack(STCKSZ)        # Execution stack.
  integer ixstck                # Execution stack pointer.
  integer i
  integer i0, n0
  integer tag
  integer ivar
  integer ival1, ival2
  integer inode1, inode2

  idstck = 1
  ixstck = 1
  call push (xstack, ixstck, iast)
  while (nstack (ixstck) != 0)
    {
      i = pop (xstack, ixstck)
      if (i == NIL)
        tag = NIL
      else
        tag = nodes(NTAG, i)
      if (tag == NIL)
        continue
      else if (tag == NDSEQ)
        {
          if (nodes(NRIGHT, i) != NIL)
            call push (xstack, ixstck, nodes(NRIGHT, i))
          if (nodes(NLEFT, i) != NIL)
            call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDID)
        {
          # Push the value of a variable.
          i0 = nodes(NITV, i)
          n0 = nodes(NITN, i)
          ivar = fndvar (vars, numvar, strngs, istrng, i0, n0)
          call push (dstack, idstck, vars(VVALUE, ivar))
        }
      else if (tag == NDINT)
        {
          # Push the value of an integer literal.
          i0 = nodes(NITV, i)
          n0 = nodes(NITN, i)
          call push (dstack, idstck, strint (strngs, i0, n0))
        }
      else if (tag == NDNEG)
        {
          # Evaluate the argument and prepare to negate it.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDNEG + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDNEG + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Negate the evaluated argument.
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, -ival1)
        }
      else if (tag == NDNOT)
        {
          # Evaluate the argument and prepare to NOT it.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDNOT + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDNOT + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # NOT the evaluated argument.
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 == 0))
        }
      else if (tag == NDAND)
        {
          # Evaluate the arguments and prepare to AND them.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDAND + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDAND + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # AND the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, _
                     logl2i (ival1 != 0 && ival2 != 0))
        }
      else if (tag == NDOR)
        {
          # Evaluate the arguments and prepare to OR them.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDOR + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDOR + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # OR the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, _
                     logl2i (ival1 != 0 || ival2 != 0))
        }
      else if (tag == NDADD)
        {
          # Evaluate the arguments and prepare to add them.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDADD + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDADD + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Add the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, ival1 + ival2)
        }
      else if (tag == NDSUB)
        {
          # Evaluate the arguments and prepare to subtract them.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDSUB + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDSUB + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Subtract the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, ival1 - ival2)
        }
      else if (tag == NDMUL)
        {
          # Evaluate the arguments and prepare to multiply them.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDMUL + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDMUL + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Multiply the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, ival1 * ival2)
        }
      else if (tag == NDDIV)
        {
          # Evaluate the arguments and prepare to compute the quotient
          # after division.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDDIV + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDDIV + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Divide the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, ival1 / ival2)
        }
      else if (tag == NDMOD)
        {
          # Evaluate the arguments and prepare to compute the
          # remainder after division.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDMOD + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDMOD + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # MOD the evaluated arguments.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, mod (ival1, ival2))
        }
      else if (tag == NDEQ)
        {
          # Evaluate the arguments and prepare to test their equality.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDEQ + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDEQ + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Test for equality.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 == ival2))
        }
      else if (tag == NDNE)
        {
          # Evaluate the arguments and prepare to test their
          # inequality.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDNE + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDNE + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Test for inequality.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 != ival2))
        }
      else if (tag == NDLT)
        {
          # Evaluate the arguments and prepare to test their
          # order.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDLT + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDLT + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Do the test.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 < ival2))
        }
      else if (tag == NDLE)
        {
          # Evaluate the arguments and prepare to test their
          # order.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDLE + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDLE + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Do the test.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 <= ival2))
        }
      else if (tag == NDGT)
        {
          # Evaluate the arguments and prepare to test their
          # order.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDGT + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDGT + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Do the test.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 > ival2))
        }
      else if (tag == NDGE)
        {
          # Evaluate the arguments and prepare to test their
          # order.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDGE + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NRIGHT, i))
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDGE + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Do the test.
          ival2 = pop (dstack, idstck)
          ival1 = pop (dstack, idstck)
          call push (dstack, idstck, logl2i (ival1 >= ival2))
        }
      else if (tag == NDASGN)
        {
          # Prepare a new node to do the actual assignment.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDASGN + STAGE2
          nodes(NITV, inode1) = nodes(NITV, nodes(NLEFT, i))
          nodes(NITN, inode1) = nodes(NITN, nodes(NLEFT, i))
          call push (xstack, ixstck, inode1)
          # Evaluate the expression.
          call push (xstack, ixstck, nodes(NRIGHT, i))
        }
      else if (tag == NDASGN + STAGE2)
        {
          # Do the actual assignment, and free the STAGE2 node.
          i0 = nodes(NITV, i)
          n0 = nodes(NITN, i)
          call frenod (nodes, frelst, i)
          ival1 = pop (dstack, idstck)
          ivar = fndvar (vars, numvar, strngs, istrng, i0, n0)
          vars(VVALUE, ivar) = ival1
        }
      else if (tag == NDIF)
        {
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDIF + STAGE2
          # The "then" and "else" clauses, respectively:
          nodes(NLEFT, inode1) = nodes(NLEFT, nodes(NRIGHT, i))
          nodes(NRIGHT, inode1) = nodes(NRIGHT, nodes(NRIGHT, i))
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDIF + STAGE2)
        {
          inode1 = nodes(NLEFT, i)  # "Then" clause.
          inode2 = nodes(NRIGHT, i) # "Else" clause.
          call frenod (nodes, frelst, i)
          ival1 = pop (dstack, idstck)
          if (ival1 != 0)
            call push (xstack, ixstck, inode1)
          else if (inode2 != NIL)
            call push (xstack, ixstck, inode2)
        }
      else if (tag == NDWHIL)
        {
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDWHIL + STAGE2
          nodes(NLEFT, inode1) = nodes(NRIGHT, i) # Loop body.
          nodes(NRIGHT, inode1) = i               # Top of loop.
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDWHIL + STAGE2)
        {
          inode1 = nodes(NLEFT, i)  # Loop body.
          inode2 = nodes(NRIGHT, i) # Top of loop.
          call frenod (nodes, frelst, i)
          ival1 = pop (dstack, idstck)
          if (ival1 != 0)
            {
              call push (xstack, ixstck, inode2) # Top of loop.
              call push (xstack, ixstck, inode1) # The body.
            }
        }
      else if (tag == NDPRTS)
        {
          # Print a string literal. (String literals occur only--and
          # always--within Prts nodes; therefore one need not devise a
          # way push strings to the stack.)
          i0 = nodes(NITV, nodes(NLEFT, i))
          n0 = nodes(NITN, nodes(NLEFT, i))
          call wrtstr (outbuf, noutbf, strngs, i0, n0)
        }
      else if (tag == NDPRTC)
        {
          # Evaluate the argument and prepare to print it.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDPRTC + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDPRTC + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Print the evaluated argument.
          ival1 = pop (dstack, idstck)
          call wrtchr (outbuf, noutbf, char (ival1))
        }
      else if (tag == NDPRTI)
        {
          # Evaluate the argument and prepare to print it.
          call newnod (nodes, frelst, inode1)
          nodes(NTAG, inode1) = NDPRTI + STAGE2
          call push (xstack, ixstck, inode1)
          call push (xstack, ixstck, nodes(NLEFT, i))
        }
      else if (tag == NDPRTI + STAGE2)
        {
          # Free the STAGE2 node.
          call frenod (nodes, frelst, i)
          # Print the evaluated argument.
          ival1 = pop (dstack, idstck)
          call wrtint (outbuf, noutbf, ival1)
        }
    }
end

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

program interp

  implicit none

  integer vars(VARSZ, MAXVAR)    # Variables.
  integer numvar                 # Number of variables.
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer nodes (NODESZ, NODSSZ) # Nodes pool.
  integer frelst                 # Head of the free list.
  character outbuf(OUTLSZ)       # Output line buffer.
  integer noutbf                 # Number of characters in outbuf.
  integer iast                   # Root node of the AST.

  numvar = 0
  istrng = 1
  noutbf = 0

  call initnd (nodes, frelst)
  call rdast (strngs, istrng, nodes, frelst, iast)

  call run (vars, numvar, _
            strngs, istrng, _
            nodes, frelst, _
            outbuf, noutbf, iast)

  if (noutbf != 0)
    call flushl (outbuf, noutbf)
end

######################################################################
Output:
$ ratfor77 interp-in-ratfor.r > interp-in-ratfor.f && gfortran -O2 -fcheck=all -std=legacy interp-in-ratfor.f && ./a.out < compiler-tests/primes.ast
3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26


Scala[edit]

The complete implementation for the compiler tasks can be found in a GitHub repository at github.com/edadma/rosettacodeCompiler which includes full unit testing for the samples given in Compiler/Sample programs.

The following code implements an interpreter for the output of the parser.

package xyz.hyperreal.rosettacodeCompiler

import scala.collection.mutable
import scala.io.Source

object ASTInterpreter {

  def fromStdin = fromSource(Source.stdin)

  def fromString(src: String) = fromSource(Source.fromString(src))

  def fromSource(s: Source) = {
    val lines = s.getLines

    def load: Node =
      if (!lines.hasNext)
        TerminalNode
      else
        lines.next.split(" +", 2) match {
          case Array(name, value) => LeafNode(name, value)
          case Array(";")         => TerminalNode
          case Array(name)        => BranchNode(name, load, load)
        }

    val vars = new mutable.HashMap[String, Any]

    def interpInt(n: Node) = interp(n).asInstanceOf[Int]

    def interpBoolean(n: Node) = interp(n).asInstanceOf[Boolean]

    def interp(n: Node): Any =
      n match {
        case TerminalNode => null
        case LeafNode("Identifier", name) =>
          vars get name match {
            case None =>
              vars(name) = 0
              0
            case Some(v) => v
          }
        case LeafNode("Integer", "'\\n'")                               => '\n'.toInt
        case LeafNode("Integer", "'\\\\'")                              => '\\'.toInt
        case LeafNode("Integer", value: String) if value startsWith "'" => value(1).toInt
        case LeafNode("Integer", value: String)                         => value.toInt
        case LeafNode("String", value: String)                          => unescape(value.substring(1, value.length - 1))
        case BranchNode("Assign", LeafNode(_, name), exp)               => vars(name) = interp(exp)
        case BranchNode("Sequence", l, r)                               => interp(l); interp(r)
        case BranchNode("Prts" | "Prti", a, _)                          => print(interp(a))
        case BranchNode("Prtc", a, _)                                   => print(interpInt(a).toChar)
        case BranchNode("Add", l, r)                                    => interpInt(l) + interpInt(r)
        case BranchNode("Subtract", l, r)                               => interpInt(l) - interpInt(r)
        case BranchNode("Multiply", l, r)                               => interpInt(l) * interpInt(r)
        case BranchNode("Divide", l, r)                                 => interpInt(l) / interpInt(r)
        case BranchNode("Mod", l, r)                                    => interpInt(l) % interpInt(r)
        case BranchNode("Negate", a, _)                                 => -interpInt(a)
        case BranchNode("Less", l, r)                                   => interpInt(l) < interpInt(r)
        case BranchNode("LessEqual", l, r)                              => interpInt(l) <= interpInt(r)
        case BranchNode("Greater", l, r)                                => interpInt(l) > interpInt(r)
        case BranchNode("GreaterEqual", l, r)                           => interpInt(l) >= interpInt(r)
        case BranchNode("Equal", l, r)                                  => interpInt(l) == interpInt(r)
        case BranchNode("NotEqual", l, r)                               => interpInt(l) != interpInt(r)
        case BranchNode("And", l, r)                                    => interpBoolean(l) && interpBoolean(r)
        case BranchNode("Or", l, r)                                     => interpBoolean(l) || interpBoolean(r)
        case BranchNode("Not", a, _)                                    => !interpBoolean(a)
        case BranchNode("While", l, r)                                  => while (interpBoolean(l)) interp(r)
        case BranchNode("If", cond, BranchNode("If", yes, no))          => if (interpBoolean(cond)) interp(yes) else interp(no)
      }

    interp(load)
  }

  abstract class Node
  case class BranchNode(name: String, left: Node, right: Node) extends Node
  case class LeafNode(name: String, value: String)             extends Node
  case object TerminalNode                                     extends Node

}

The above code depends on the function unescape() to perform string escape sequence translation. That function is defined in the following separate source file.

package xyz.hyperreal

import java.io.ByteArrayOutputStream

package object rosettacodeCompiler {

  val escapes = "\\\\b|\\\\f|\\\\t|\\\\r|\\\\n|\\\\\\\\|\\\\\"" r

  def unescape(s: String) =
    escapes.replaceAllIn(s, _.matched match {
      case "\\b"  => "\b"
      case "\\f"  => "\f"
      case "\\t"  => "\t"
      case "\\r"  => "\r"
      case "\\n"  => "\n"
      case "\\\\" => "\\"
      case "\\\"" => "\""
    })

  def capture(thunk: => Unit) = {
    val buf = new ByteArrayOutputStream

    Console.withOut(buf)(thunk)
    buf.toString
  }

}

Scheme[edit]

(import (scheme base)
        (scheme file)
        (scheme process-context)
        (scheme write)
        (only (srfi 13) string-delete string-index string-trim))

;; Mappings from operation symbols to internal procedures.
;; We define operations appropriate to virtual machine:
;; e.g. division must return an int, not a rational
;; boolean values are treated as numbers: 0 is false, other is true
(define *unary-ops* 
  (list (cons 'Negate (lambda (a) (- a)))
        (cons 'Not (lambda (a) (if (zero? a) 1 0)))))
(define *binary-ops* 
  (let ((number-comp (lambda (op) (lambda (a b) (if (op a b) 1 0)))))
    (list (cons 'Add +)
          (cons 'Subtract -)
          (cons 'Multiply *)
          (cons 'Divide (lambda (a b) (truncate (/ a b)))) ; int division
          (cons 'Mod modulo)
          (cons 'Less (number-comp <))
          (cons 'Greater (number-comp >))
          (cons 'LessEqual (number-comp <=))
          (cons 'GreaterEqual (number-comp >=))
          (cons 'Equal (lambda (a b) (if (= a b) 1 0)))
          (cons 'NotEqual (lambda (a b) (if (= a b) 0 1)))
          (cons 'And (lambda (a b) ; make "and" work on numbers
                       (if (and (not (zero? a)) (not (zero? b))) 1 0)))
          (cons 'Or (lambda (a b) ; make "or" work on numbers
                      (if (or (not (zero? a)) (not (zero? b))) 1 0))))))

;; Read AST from given filename
;; - return as an s-expression
(define (read-code filename)
  (define (read-expr)
    (let ((line (string-trim (read-line))))
      (if (string=? line ";")
        '()
        (let ((space (string-index line #\space)))
          (if space
            (list (string->symbol (string-trim (substring line 0 space)))
                  (string-trim (substring line space (string-length line))))
            (list (string->symbol line) (read-expr) (read-expr)))))))
  ;
  (with-input-from-file
    filename
    (lambda ()
      (read-expr))))

;; interpret AST provided as an s-expression
(define run-program
  (let ((env '())) ; env is an association list for variable names
    (lambda (expr)
      (define (tidy-string str)   
        (string-delete ; remove any quote marks
          #\" ; " (to appease Rosetta code's syntax highlighter)
          (list->string 
            (let loop ((chars (string->list str))) ; replace newlines, obeying \\n
              (cond ((< (length chars) 2) ; finished list
                     chars)
                    ((and (>= (length chars) 3) ; preserve \\n
                          (char=? #\\ (car chars))
                          (char=? #\\ (cadr chars))
                          (char=? #\n (cadr (cdr chars))))
                     (cons (car chars)
                           (cons (cadr chars)
                                 (cons (cadr (cdr chars))
                                       (loop (cdr (cdr (cdr chars))))))))
                    ((and (char=? #\\ (car chars)) ; replace \n with newline
                          (char=? #\n (cadr chars)))
                     (cons #\newline (loop (cdr (cdr chars)))))
                    (else ; keep char and look further
                      (cons (car chars) (loop (cdr chars)))))))))
      ; define some more meaningful names for fields
      (define left cadr)
      (define right (lambda (x) (cadr (cdr x))))
      ;
      (if (null? expr)
        '()
        (case (car expr) ; interpret AST from the head node
          ((Integer)
           (string->number (left expr)))
          ((Identifier)
           (let ((val (assq (string->symbol (left expr)) env)))
             (if val
               (cdr val)
               (error "Variable not in environment"))))
          ((String)
           (left expr))
          ((Assign)
           (set! env (cons (cons (string->symbol (left (left expr)))
                                 (run-program (right expr)))
                           env)))
          ((Add Subtract Multiply Divide Mod 
                Less Greater LessEqual GreaterEqual Equal NotEqual
                And Or)
           (let ((binop (assq (car expr) *binary-ops*)))
             (if binop
               ((cdr binop) (run-program (left expr)) 
                            (run-program (right expr)))
               (error "Could not find binary operator"))))
          ((Negate Not) 
           (let ((unaryop (assq (car expr) *unary-ops*)))
             (if unaryop
               ((cdr unaryop) (run-program (left expr)))
               (error "Could not find unary operator"))))
          ((If)
           (if (not (zero? (run-program (left expr)))) ; 0 means false
             (run-program (left (right expr)))
             (run-program (right (right expr))))
           '())
          ((While)
           (let loop ()
             (unless (zero? (run-program (left expr)))
               (run-program (right expr))
               (loop)))
           '())
          ((Prtc)
           (display (integer->char (run-program (left expr))))
           '())
          ((Prti)
           (display (run-program (left expr)))
           '())
          ((Prts)
           (display (tidy-string (run-program (left expr))))
           '())
          ((Sequence)
           (run-program (left expr))
           (run-program (right expr))
           '())
          (else
            (error "Unknown node type")))))))

;; read AST from file and interpret, from filename passed on command line
(if (= 2 (length (command-line)))
  (run-program (read-code (cadr (command-line))))
  (display "Error: pass an ast filename\n"))
Output:

Output for primes program from above. Also tested on programs in Compiler/Sample programs.

3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26

Wren[edit]

Translation of: Go
Library: Wren-dynamic
Library: Wren-fmt
Library: Wren-ioutil
import "/dynamic" for Enum, Struct, Tuple
import "/fmt" for Conv
import "/ioutil" for FileUtil

var nodes = [
    "Ident",
    "String",
    "Integer",
    "Sequence",
    "If",
    "Prtc",
    "Prts",
    "Prti",
    "While",
    "Assign",
    "Negate",
    "Not",
    "Mul",
    "Div",
    "Mod",
    "Add",
    "Sub",
    "Lss",
    "Leq",
    "Gtr",
    "Geq",
    "Eql",
    "Neq",
    "And",
    "Or"
]

var Node = Enum.create("Node", nodes)

var Tree = Struct.create("Tree", ["nodeType", "left", "right", "value"])

// dependency: Ordered by Node value, must remain in same order as Node enum
var Atr = Tuple.create("Atr", ["enumText", "nodeType"])

var atrs = [
    Atr.new("Identifier", Node.Ident),
    Atr.new("String", Node.String),
    Atr.new("Integer", Node.Integer),
    Atr.new("Sequence", Node.Sequence),
    Atr.new("If", Node.If),
    Atr.new("Prtc", Node.Prtc),
    Atr.new("Prts", Node.Prts),
    Atr.new("Prti", Node.Prti),
    Atr.new("While", Node.While),
    Atr.new("Assign", Node.Assign),
    Atr.new("Negate", Node.Negate),
    Atr.new("Not", Node.Not),
    Atr.new("Multiply", Node.Mul),
    Atr.new("Divide", Node.Div),
    Atr.new("Mod", Node.Mod),
    Atr.new("Add", Node.Add),
    Atr.new("Subtract", Node.Sub),
    Atr.new("Less", Node.Lss),
    Atr.new("LessEqual", Node.Leq),
    Atr.new("Greater", Node.Gtr),
    Atr.new("GreaterEqual", Node.Geq),
    Atr.new("Equal", Node.Eql),
    Atr.new("NotEqual", Node.Neq),
    Atr.new("And", Node.And),
    Atr.new("Or", Node.Or),
]

var stringPool = []
var globalNames = []
var globalValues = {}

var reportError = Fn.new { |msg| Fiber.abort("error : %(msg)") }

var makeNode = Fn.new { |nodeType, left, right| Tree.new(nodeType, left, right, 0) }

var makeLeaf = Fn.new { |nodeType, value| Tree.new(nodeType, null, null, value) }

// interpret the parse tree
var interp  // recursive function
interp = Fn.new { |x|
    if (!x) return 0
    var nt = x.nodeType
    if (nt == Node.Integer) return x.value
    if (nt == Node.Ident) return globalValues[x.value]
    if (nt == Node.String) return x.value
    if (nt == Node.Assign) {
        var n = interp.call(x.right)
        globalValues[x.left.value] = n
        return n
    }
    if (nt == Node.Add) return interp.call(x.left) +  interp.call(x.right)
    if (nt == Node.Sub) return interp.call(x.left) -  interp.call(x.right)
    if (nt == Node.Mul) return interp.call(x.left) *  interp.call(x.right)
    if (nt == Node.Div) return (interp.call(x.left) / interp.call(x.right)).truncate
    if (nt == Node.Mod) return interp.call(x.left) %  interp.call(x.right)
    if (nt == Node.Lss) return Conv.btoi(interp.call(x.left) <  interp.call(x.right))
    if (nt == Node.Gtr) return Conv.btoi(interp.call(x.left) >  interp.call(x.right))
    if (nt == Node.Leq) return Conv.btoi(interp.call(x.left) <= interp.call(x.right))
    if (nt == Node.Eql) return Conv.btoi(interp.call(x.left) == interp.call(x.right))
    if (nt == Node.Neq) return Conv.btoi(interp.call(x.left) != interp.call(x.right))
    if (nt == Node.And) return Conv.btoi(Conv.itob(interp.call(x.left)) && Conv.itob(interp.call(x.right)))
    if (nt == Node.Or)  return Conv.btoi(Conv.itob(interp.call(x.left)) || Conv.itob(interp.call(x.right)))
    if (nt == Node.Negate) return -interp.call(x.left)
    if (nt == Node.Not) return (interp.call(x.left) == 0) ? 1 : 0
    if (nt == Node.If) {
        if (interp.call(x.left) != 0) {
            interp.call(x.right.left)
        } else {
            interp.call(x.right.right)
        }
        return 0
    }
    if (nt == Node.While) {
        while (interp.call(x.left) != 0) interp.call(x.right)
        return 0
    }
    if (nt == Node.Prtc) {
        System.write(String.fromByte(interp.call(x.left)))
        return 0
    }
    if (nt == Node.Prti) {
        System.write(interp.call(x.left))
        return 0
    }
    if (nt == Node.Prts) {
        System.write(stringPool[interp.call(x.left)])
        return 0
    }
    if (nt == Node.Sequence) {
        interp.call(x.left)
        interp.call(x.right)
        return 0
    }
    reportError.call("interp: unknown tree type %(x.nodeType)")
}

var getEnumValue = Fn.new { |name|
    for (atr in atrs) {
        if (atr.enumText == name) return atr.nodeType
    }
    reportError.call("Unknown token %(name)")
}

var fetchStringOffset = Fn.new { |s|
    var d = ""
    s = s[1...-1]
    var i = 0
    while (i < s.count) {
        if (s[i] == "\\" && (i+1) < s.count) {
            if (s[i+1] == "n") {
                d = d + "\n"
                i = i + 1
            } else if (s[i+1] == "\\") {
                d = d + "\\"
                i = i + 1
            }
        } else {
            d = d + s[i]
        }
        i = i + 1
    }
    s = d
    for (i in 0...stringPool.count) {
        if (s == stringPool[i]) return i
    }
    stringPool.add(s)
    return stringPool.count - 1
}

var fetchVarOffset = Fn.new { |name|
    for (i in 0...globalNames.count) {
        if (globalNames[i] == name) return i
    }
    globalNames.add(name)
    return globalNames.count - 1
}

var lines = []
var lineCount = 0
var lineNum = 0

var loadAst  // recursive function
loadAst = Fn.new {
    var nodeType = 0
    var s = ""
    if (lineNum < lineCount) {
        var line = lines[lineNum].trimEnd(" \t")
        lineNum = lineNum + 1
        var tokens = line.split(" ").where { |s| s != "" }.toList
        var first = tokens[0]
        if (first[0] == ";") return null
        nodeType = getEnumValue.call(first)
        var le = tokens.count
        if (le == 2) {
            s = tokens[1]
        } else if (le > 2) {
            var idx = line.indexOf("\"")
            s = line[idx..-1]
        }
    }
    if (s != "") {
        var n
        if (nodeType == Node.Ident) {
            n = fetchVarOffset.call(s)
        } else if (nodeType == Node.Integer) {
            n = Num.fromString(s)
        } else if (nodeType == Node.String) {
            n = fetchStringOffset.call(s)
        } else {
            reportError.call("Unknown node type: %(s)")
        }
        return makeLeaf.call(nodeType, n)
    }
    var left  = loadAst.call()
    var right = loadAst.call()
    return makeNode.call(nodeType, left, right)
}

lines = FileUtil.readLines("ast.txt")
lineCount = lines.count
var x = loadAst.call()
interp.call(x)
Output:
3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26

Zig[edit]

const std = @import("std");

pub const ASTInterpreterError = error{OutOfMemory};

pub const ASTInterpreter = struct {
    output: std.ArrayList(u8),
    globals: std.StringHashMap(NodeValue),

    const Self = @This();

    pub fn init(allocator: std.mem.Allocator) Self {
        return ASTInterpreter{
            .output = std.ArrayList(u8).init(allocator),
            .globals = std.StringHashMap(NodeValue).init(allocator),
        };
    }

    // Returning `NodeValue` from this function looks suboptimal and this should
    // probably be a separate type.
    pub fn interp(self: *Self, tree: ?*Tree) ASTInterpreterError!?NodeValue {
        if (tree) |t| {
            switch (t.typ) {
                .sequence => {
                    _ = try self.interp(t.left);
                    _ = try self.interp(t.right);
                },
                .assign => try self.globals.put(
                    t.left.?.value.?.string,
                    (try self.interp(t.right)).?,
                ),
                .identifier => return self.globals.get(t.value.?.string).?,
                .kw_while => {
                    while ((try self.interp(t.left)).?.integer != 0) {
                        _ = try self.interp(t.right);
                    }
                },
                .kw_if => {
                    const condition = (try self.interp(t.left)).?.integer;
                    if (condition == 1) {
                        _ = try self.interp(t.right.?.left);
                    } else {
                        _ = try self.interp(t.right.?.right);
                    }
                },
                .less => return NodeValue{ .integer = try self.binOp(less, t.left, t.right) },
                .less_equal => return NodeValue{ .integer = try self.binOp(less_equal, t.left, t.right) },
                .greater => return NodeValue{ .integer = try self.binOp(greater, t.left, t.right) },
                .greater_equal => return NodeValue{ .integer = try self.binOp(greater_equal, t.left, t.right) },
                .add => return NodeValue{ .integer = try self.binOp(add, t.left, t.right) },
                .subtract => return NodeValue{ .integer = try self.binOp(sub, t.left, t.right) },
                .multiply => return NodeValue{ .integer = try self.binOp(mul, t.left, t.right) },
                .divide => return NodeValue{ .integer = try self.binOp(div, t.left, t.right) },
                .mod => return NodeValue{ .integer = try self.binOp(mod, t.left, t.right) },
                .equal => return NodeValue{ .integer = try self.binOp(equal, t.left, t.right) },
                .not_equal => return NodeValue{ .integer = try self.binOp(not_equal, t.left, t.right) },
                .bool_and => return NodeValue{ .integer = try self.binOp(@"and", t.left, t.right) },
                .bool_or => return NodeValue{ .integer = try self.binOp(@"or", t.left, t.right) },
                .negate => return NodeValue{ .integer = -(try self.interp(t.left)).?.integer },
                .not => {
                    const arg = (try self.interp(t.left)).?.integer;
                    const result: i32 = if (arg == 0) 1 else 0;
                    return NodeValue{ .integer = result };
                },
                .prts =>