Compiler/AST interpreter: Difference between revisions

m
m (→‎{{header|Wren}}: Minor tidy)
 
(7 intermediate revisions by 5 users not shown)
Line 11:
;Loading the AST from the syntax analyzer is as simple as (pseudo code):
 
<langsyntaxhighlight lang="python">def load_ast()
line = readline()
# Each line has at least one token
Line 31:
left = load_ast()
right = load_ast()
return make_node(node_type, left, right)</langsyntaxhighlight>
 
; The interpreter algorithm is relatively simple:
 
<langsyntaxhighlight lang="python">interp(x)
if x == NULL return NULL
elif x.node_type == Integer return x.value converted to an integer
Line 66:
return NULL
else
error("unknown node type")</langsyntaxhighlight>
 
Notes:
Line 88:
|-
| style="vertical-align:top" |
<langsyntaxhighlight lang="c">/*
Simple prime number generator
*/
Line 107:
}
}
print("Total primes found: ", count, "\n"); </langsyntaxhighlight>
 
| style="vertical-align:top" |
Line 160:
 
=={{header|ALGOL W}}==
<langsyntaxhighlight lang="algolw">begin % AST interpreter %
% parse tree nodes %
record node( integer type
Line 432:
% parse the output from the syntax analyser and intetrpret parse tree %
eval( readNode )
end.</langsyntaxhighlight>
{{out}}
<pre>
Line 440:
11 is prime
...
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26
</pre>
 
=={{header|ATS}}==
For ATS2 with a garbage collector.
<syntaxhighlight lang="ats">
(* 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
 
(*------------------------------------------------------------------*)
</syntaxhighlight>
 
{{out|case=primes}}
<pre>$ 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
Line 449 ⟶ 1,326:
=={{header|C}}==
Tested with gcc 4.81 and later, compiles warning free with -Wall -Wextra
<langsyntaxhighlight Clang="c">#include <stdlib.h>
#include <stdio.h>
#include <string.h>
Line 709 ⟶ 1,586:
 
return 0;
}</langsyntaxhighlight>
 
{{out|case=prime numbers output from AST interpreter}}
Line 747 ⟶ 1,624:
Code by Steve Williams. Tested with GnuCOBOL 2.2.
 
<langsyntaxhighlight cobollang="cobolfree"> >>SOURCE FORMAT IS FREE
identification division.
*> this code is dedicated to the public domain
Line 1,243 ⟶ 2,120:
.
end program reporterror.
end program astinterpreter.</langsyntaxhighlight>
 
{{out|case=Primes}}
Line 1,276 ⟶ 2,153:
=={{header|Forth}}==
Tested with Gforth 0.7.3
<langsyntaxhighlight Forthlang="forth">CREATE BUF 0 , \ single-character look-ahead buffer
: PEEK BUF @ 0= IF KEY BUF ! THEN BUF @ ;
: GETC PEEK 0 BUF ! ;
Line 1,365 ⟶ 2,242:
 
GETAST INTERP
</syntaxhighlight>
</lang>
Passes all tests.
 
Line 1,372 ⟶ 2,249:
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.
 
<langsyntaxhighlight lang="fortran">!!!
!!! An implementation of the Rosetta Code interpreter task:
!!! https://rosettacode.org/wiki/Compiler/AST_interpreter
Line 2,829 ⟶ 3,706:
end subroutine print_usage
end program Interp</langsyntaxhighlight>
 
{{out}}
Line 2,862 ⟶ 3,739:
=={{header|Go}}==
{{trans|C}}
<langsyntaxhighlight lang="go">package main
 
import (
Line 3,157 ⟶ 4,034:
x := loadAst()
interp(x)
}</langsyntaxhighlight>
 
{{out}}
Line 3,194 ⟶ 4,071:
Implementation:
 
<langsyntaxhighlight Jlang="j">outbuf=: ''
emit=:{{
outbuf=: outbuf,y
Line 3,260 ⟶ 4,137:
end.
}}
</syntaxhighlight>
</lang>
 
Task example:
 
<langsyntaxhighlight Jlang="j">primes=:{{)n
/*
Simple prime number generator
Line 3,315 ⟶ 4,192:
Total primes found: 26
 
</langsyntaxhighlight>
 
=={{header|Java}}==
<langsyntaxhighlight lang="java">
import java.util.Scanner;
import java.io.File;
Line 3,558 ⟶ 4,435:
}
 
</syntaxhighlight>
</lang>
 
=={{header|Julia}}==
<langsyntaxhighlight lang="julia">struct Anode
node_type::String
left::Union{Nothing, Anode}
Line 3,728 ⟶ 4,605:
 
interp(load_ast(lio))
</langsyntaxhighlight>{{output}}<pre>
3 is prime
5 is prime
Line 3,761 ⟶ 4,638:
Using AST produced by the parser from the task “syntax analyzer”.
 
<langsyntaxhighlight Nimlang="nim">import os, strutils, streams, tables
 
import ast_parser
Line 3,924 ⟶ 4,801:
if toClose: stream.close()
 
discard ast.interp()</langsyntaxhighlight>
 
{{out}}
Line 3,974 ⟶ 4,851:
Tested with perl v5.26.1
 
<langsyntaxhighlight Perllang="perl">#!/usr/bin/perl
 
use strict; # interpreter.pl - execute a flatAST
Line 4,018 ⟶ 4,895:
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 }</langsyntaxhighlight>
Passes all tests.
 
=={{header|Phix}}==
Reusing parse.e from the [[Compiler/syntax_analyzer#Phix|Syntax Analyzer task]]
<!--<langsyntaxhighlight Phixlang="phix">(phixonline)-->
<span style="color: #000080;font-style:italic;">--
-- demo\rosetta\Compiler\interp.exw
Line 4,093 ⟶ 4,970:
<span style="color: #000080;font-style:italic;">--main(command_line())</span>
<span style="color: #000000;">main</span><span style="color: #0000FF;">({</span><span style="color: #000000;">0</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"primes.c"</span><span style="color: #0000FF;">})</span>
<!--</langsyntaxhighlight>-->
{{out}}
<pre>
Line 4,126 ⟶ 5,003:
=={{header|Python}}==
Tested with Python 2.7 and 3.x
<langsyntaxhighlight Pythonlang="python">from __future__ import print_function
import sys, shlex, operator
 
Line 4,290 ⟶ 5,167:
 
n = load_ast()
interp(n)</langsyntaxhighlight>
 
{{out|case=prime numbers output from AST interpreter}}
Line 4,324 ⟶ 5,201:
</pre>
</b>
 
=={{header|RATFOR}}==
{{works with|ratfor77|[https://sourceforge.net/p/chemoelectric/ratfor77/ public domain 1.0]}}
{{works with|gfortran|11.3.0}}
{{works with|f2c|20100827}}
 
 
<syntaxhighlight lang="ratfor">######################################################################
#
# 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
 
######################################################################</syntaxhighlight>
 
{{out}}
<pre>$ 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</pre>
 
 
 
=={{header|Scala}}==
Line 4,330 ⟶ 6,530:
The following code implements an interpreter for the output of the [http://rosettacode.org/wiki/Compiler/syntax_analyzer#Scala parser].
 
<langsyntaxhighlight lang="scala">
package xyz.hyperreal.rosettacodeCompiler
 
Line 4,408 ⟶ 6,608:
 
}
</syntaxhighlight>
</lang>
 
The above code depends on the function <tt>unescape()</tt> to perform string escape sequence translation. That function is defined in the following separate source file.
 
<langsyntaxhighlight lang="scala">
package xyz.hyperreal
 
Line 4,440 ⟶ 6,640:
 
}
</syntaxhighlight>
</lang>
 
=={{header|Scheme}}==
 
<langsyntaxhighlight lang="scheme">
(import (scheme base)
(scheme file)
Line 4,582 ⟶ 6,782:
(run-program (read-code (cadr (command-line))))
(display "Error: pass an ast filename\n"))
</syntaxhighlight>
</lang>
 
{{out}}
Line 4,622 ⟶ 6,822:
{{libheader|Wren-fmt}}
{{libheader|Wren-ioutil}}
<langsyntaxhighlight ecmascriptlang="wren">import "./dynamic" for Enum, Struct, Tuple
import "./fmt" for Conv
import "./ioutil" for FileUtil
 
var nodes = [
Line 4,843 ⟶ 7,043:
lineCount = lines.count
var x = loadAst.call()
interp.call(x)</langsyntaxhighlight>
 
{{out}}
Line 4,874 ⟶ 7,074:
Total primes found: 26
</pre>
 
{{works with|Zig|0.11.0}}
To simplify memory allocation management <tt>std.heap.ArenaAllocator</tt> is used in the code below. This allows all an arena's allocations to be freed together with a single call to arena.deinit()
 
=={{header|Zig}}==
<langsyntaxhighlight lang="zig">
const std = @import("std");
 
Line 4,942 ⟶ 7,145:
.prts => _ = try self.out("{s}", .{(try self.interp(t.left)).?.string}),
.prti => _ = try self.out("{d}", .{(try self.interp(t.left)).?.integer}),
.prtc => _ = try self.out("{c}", .{@intCastas(u8, @intCast((try self.interp(t.left)).?.integer))}),
.string => return t.value,
.integer => return t.value,
Line 4,961 ⟶ 7,164:
fn binOp(
self: *Self,
comptime func: fn (a: i32, b: i32) i32,
a: ?*Tree,
b: ?*Tree,
Line 4,972 ⟶ 7,175:
 
fn less(a: i32, b: i32) i32 {
return @boolToIntintFromBool(a < b);
}
fn less_equal(a: i32, b: i32) i32 {
return @boolToIntintFromBool(a <= b);
}
fn greater(a: i32, b: i32) i32 {
return @boolToIntintFromBool(a > b);
}
fn greater_equal(a: i32, b: i32) i32 {
return @boolToIntintFromBool(a >= b);
}
fn equal(a: i32, b: i32) i32 {
return @boolToIntintFromBool(a == b);
}
fn not_equal(a: i32, b: i32) i32 {
return @boolToIntintFromBool(a != b);
}
fn add(a: i32, b: i32) i32 {
Line 5,005 ⟶ 7,208:
}
fn @"or"(a: i32, b: i32) i32 {
return @boolToIntintFromBool((a != 0) or (b != 0));
}
fn @"and"(a: i32, b: i32) i32 {
return @boolToIntintFromBool((a != 0) and (b != 0));
}
};
Line 5,017 ⟶ 7,220:
const allocator = arena.allocator();
 
var arg_it = try std.process.argsargsWithAllocator(allocator);
_ = try arg_it.next(allocator) orelse unreachable; // program name
const file_name = arg_it.next(allocator);
// We accept both files and standard input.
var file_handle = blk: {
if (file_name) |file_name_delimited| {
const fname: []const u8 = try file_name_delimited;
break :blk try std.fs.cwd().openFile(fname, .{});
} else {
Line 5,139 ⟶ 7,342:
fn loadASTHelper(
allocator: std.mem.Allocator,
line_it: *std.mem.SplitIterator(u8, std.mem.DelimiterType.sequence),
string_pool: *std.ArrayList([]const u8),
) LoadASTError!?*Tree {
Line 5,192 ⟶ 7,395:
}
}
</syntaxhighlight>
</lang>
 
=={{header|zkl}}==
<langsyntaxhighlight lang="zkl">const{ var _n=-1; var[proxy]N=fcn{ _n+=1 }; } // enumerator
const FETCH=N, STORE=N, PUSH=N, ADD=N, SUB=N, MUL=N, DIV=N, MOD=N,
LT=N, GT=N, LE=N, GE=N, EQ=N, NE=N,
Line 5,253 ⟶ 7,456:
}
Void
}</langsyntaxhighlight>
<langsyntaxhighlight lang="zkl">fcn load_ast(file){
line:=file.readln().strip(); // one or two tokens
if(line[0]==";") return(Void);
Line 5,266 ⟶ 7,469:
left,right := load_ast(file),load_ast(file);
Node(type,Void,left,right)
}</langsyntaxhighlight>
<langsyntaxhighlight lang="zkl">ast:=load_ast(File(vm.nthArg(0)));
runNode(ast);</langsyntaxhighlight>
{{out}}
<pre>
9,476

edits