Compiler/AST interpreter: Difference between revisions
m
→{{header|Wren}}: Minor tidy
m (Additional samples) |
m (→{{header|Wren}}: Minor tidy) |
||
| (46 intermediate revisions by 20 users not shown) | |||
Line 1:
{{
An AST interpreter interprets an [https://en.wikipedia.org/wiki/Abstract_syntax_tree Abstract Syntax Tree (AST)]
Line 11:
;Loading the AST from the syntax analyzer is as simple as (pseudo code):
<
line = readline()
# Each line has at least one token
Line 31:
left = load_ast()
right = load_ast()
return make_node(node_type, left, right)</
; The interpreter algorithm is relatively simple:
<
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")</
Notes:
Line 88:
|-
| style="vertical-align:top" |
<
Simple prime number generator
*/
Line 107:
}
}
print("Total primes found: ", count, "\n"); </
| style="vertical-align:top" |
Line 141:
|}
; Additional examples
Your solution should pass all the test cases above and the additional tests found '''[[Compiler/Sample_programs|Here]]'''.
{{task heading|Reference}}
The C and Python versions can be considered reference implementations.
;Related Tasks
Line 152 ⟶ 158:
<hr>
__TOC__
=={{header|ALGOL W}}==
<syntaxhighlight lang="algolw">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.</syntaxhighlight>
{{out}}
<pre>
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
</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
97 is prime
101 is prime
Total primes found: 26
</pre>
=={{header|C}}==
Tested with gcc 4.81 and later, compiles warning free with -Wall -Wextra
<
#include <stdio.h>
#include <string.h>
Line 255 ⟶ 1,426:
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);
Line 341 ⟶ 1,513:
while ((*p++ = *q++) != '\0') {
if (q[-1] == '\\
++q;
} else if (q[0] == '\\') {
++q;
}
}
}
Line 410 ⟶ 1,586:
return 0;
}</
{{out|case=prime numbers output from AST interpreter}}
Line 444 ⟶ 1,620:
</pre>
</b>
=={{header|COBOL}}==
Code by Steve Williams. Tested with GnuCOBOL 2.2.
<syntaxhighlight lang="cobolfree"> >>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.</syntaxhighlight>
{{out|case=Primes}}
<pre>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</pre>
=={{header|Forth}}==
Tested with Gforth 0.7.3
<syntaxhighlight lang="forth">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
</syntaxhighlight>
Passes all tests.
=={{header|Fortran}}==
{{works with|gfortran|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.
<syntaxhighlight lang="fortran">!!!
!!! 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</syntaxhighlight>
{{out}}
$ ./lex compiler-tests/primes.t | ./parse | ./Interp
<pre>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|Go}}==
{{trans|C}}
<syntaxhighlight lang="go">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)
}</syntaxhighlight>
{{out}}
Prime Numbers example:
<pre>
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|J}}==
Implementation:
<syntaxhighlight lang="j">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.
}}
</syntaxhighlight>
Task example:
<syntaxhighlight lang="j">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
</syntaxhighlight>
=={{header|Java}}==
<syntaxhighlight lang="java">
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());
}
}
}
}
</syntaxhighlight>
=={{header|Julia}}==
<syntaxhighlight lang="julia">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))
</syntaxhighlight>{{output}}<pre>
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|Nim}}==
Using AST produced by the parser from the task “syntax analyzer”.
<syntaxhighlight lang="nim">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()</syntaxhighlight>
{{out}}
Output from the program ASCII Mandelbrot: https://rosettacode.org/wiki/Compiler/Sample_programs#Ascii_Mandlebrot
<pre>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</pre>
=={{header|Perl}}==
Tested with perl v5.26.1
<syntaxhighlight lang="perl">#!/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 }</syntaxhighlight>
Passes all tests.
=={{header|Phix}}==
Reusing parse.e from the [[Compiler/syntax_analyzer#Phix|Syntax Analyzer task]]
<!--<syntaxhighlight lang="phix">(phixonline)-->
<span style="color: #000080;font-style:italic;">--
-- demo\rosetta\Compiler\interp.exw
-- ================================
--</span>
<span style="color: #008080;">with</span> <span style="color: #008080;">javascript_semantics</span>
<span style="color: #008080;">include</span> <span style="color: #000000;">parse</span><span style="color: #0000FF;">.</span><span style="color: #000000;">e</span>
<span style="color: #004080;">sequence</span> <span style="color: #000000;">vars</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{},</span>
<span style="color: #000000;">vals</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{}</span>
<span style="color: #008080;">function</span> <span style="color: #000000;">var_idx</span><span style="color: #0000FF;">(</span><span style="color: #004080;">sequence</span> <span style="color: #000000;">inode</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">inode</span><span style="color: #0000FF;">[</span><span style="color: #000000;">1</span><span style="color: #0000FF;">]!=</span><span style="color: #000000;">tk_Identifier</span> <span style="color: #008080;">then</span> <span style="color: #0000FF;">?</span><span style="color: #000000;">9</span><span style="color: #0000FF;">/</span><span style="color: #000000;">0</span> <span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #004080;">string</span> <span style="color: #000000;">ident</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">inode</span><span style="color: #0000FF;">[</span><span style="color: #000000;">2</span><span style="color: #0000FF;">]</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">n</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">find</span><span style="color: #0000FF;">(</span><span style="color: #000000;">ident</span><span style="color: #0000FF;">,</span><span style="color: #000000;">vars</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">n</span><span style="color: #0000FF;">=</span><span style="color: #000000;">0</span> <span style="color: #008080;">then</span>
<span style="color: #000000;">vars</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">append</span><span style="color: #0000FF;">(</span><span style="color: #000000;">vars</span><span style="color: #0000FF;">,</span><span style="color: #000000;">ident</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">vals</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">append</span><span style="color: #0000FF;">(</span><span style="color: #000000;">vals</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">n</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">vars</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">return</span> <span style="color: #000000;">n</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<span style="color: #008080;">function</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #004080;">object</span> <span style="color: #000000;">t</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">t</span><span style="color: #0000FF;">!=</span><span style="color: #004600;">NULL</span> <span style="color: #008080;">then</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">ntype</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">t</span><span style="color: #0000FF;">[</span><span style="color: #000000;">1</span><span style="color: #0000FF;">]</span>
<span style="color: #004080;">object</span> <span style="color: #000000;">t2</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">t</span><span style="color: #0000FF;">[</span><span style="color: #000000;">2</span><span style="color: #0000FF;">],</span>
<span style="color: #000000;">t3</span> <span style="color: #0000FF;">=</span> <span style="color: #008080;">iff</span><span style="color: #0000FF;">(</span><span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t</span><span style="color: #0000FF;">)=</span><span style="color: #000000;">3</span><span style="color: #0000FF;">?</span><span style="color: #000000;">t</span><span style="color: #0000FF;">[</span><span style="color: #000000;">3</span><span style="color: #0000FF;">]:</span><span style="color: #000000;">0</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">switch</span> <span style="color: #000000;">ntype</span> <span style="color: #008080;">do</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Sequence</span><span style="color: #0000FF;">:</span> <span style="color: #0000FF;">{}</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span> <span style="color: #0000FF;">{}</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_assign</span><span style="color: #0000FF;">:</span> <span style="color: #000000;">vals</span><span style="color: #0000FF;">[</span><span style="color: #000000;">var_idx</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Identifier</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #000000;">vals</span><span style="color: #0000FF;">[</span><span style="color: #000000;">var_idx</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t</span><span style="color: #0000FF;">)]</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Integer</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #000000;">t2</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_String</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #000000;">t2</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_lt</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span> <span style="color: #0000FF;"><</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_add</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span> <span style="color: #0000FF;">+</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_sub</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span> <span style="color: #0000FF;">-</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_while</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">while</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span> <span style="color: #008080;">do</span> <span style="color: #0000FF;">{}</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">)</span> <span style="color: #008080;">end</span> <span style="color: #008080;">while</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Prints</span><span style="color: #0000FF;">:</span> <span style="color: #7060A8;">puts</span><span style="color: #0000FF;">(</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">))</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_Printi</span><span style="color: #0000FF;">:</span> <span style="color: #7060A8;">printf</span><span style="color: #0000FF;">(</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"%d"</span><span style="color: #0000FF;">,</span><span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">))</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_putc</span><span style="color: #0000FF;">:</span> <span style="color: #7060A8;">printf</span><span style="color: #0000FF;">(</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"%c"</span><span style="color: #0000FF;">,</span><span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">))</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_and</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span> <span style="color: #008080;">and</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_or</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span> <span style="color: #008080;">or</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_le</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span> <span style="color: #0000FF;"><=</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_ge</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span> <span style="color: #0000FF;">>=</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_ne</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span> <span style="color: #0000FF;">!=</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_gt</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span> <span style="color: #0000FF;">></span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_mul</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span> <span style="color: #0000FF;">*</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_div</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #7060A8;">trunc</span><span style="color: #0000FF;">(</span><span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)/</span><span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">))</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_mod</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #7060A8;">remainder</span><span style="color: #0000FF;">(</span><span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">),</span><span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">))</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_if</span><span style="color: #0000FF;">:</span> <span style="color: #0000FF;">{}</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t3</span><span style="color: #0000FF;">[</span><span style="color: #008080;">iff</span><span style="color: #0000FF;">(</span><span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)?</span><span style="color: #000000;">2</span><span style="color: #0000FF;">:</span><span style="color: #000000;">3</span><span style="color: #0000FF;">)])</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_not</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #008080;">not</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">case</span> <span style="color: #000000;">tk_neg</span><span style="color: #0000FF;">:</span> <span style="color: #008080;">return</span> <span style="color: #0000FF;">-</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t2</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">else</span>
<span style="color: #000000;">error</span><span style="color: #0000FF;">(</span><span style="color: #008000;">"unknown node type"</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">switch</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">return</span> <span style="color: #004600;">NULL</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<span style="color: #008080;">procedure</span> <span style="color: #000000;">main</span><span style="color: #0000FF;">(</span><span style="color: #004080;">sequence</span> <span style="color: #000000;">cl</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">open_files</span><span style="color: #0000FF;">(</span><span style="color: #000000;">cl</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">toks</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">lex</span><span style="color: #0000FF;">()</span>
<span style="color: #004080;">object</span> <span style="color: #000000;">t</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">parse</span><span style="color: #0000FF;">()</span>
<span style="color: #0000FF;">{}</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">interp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">t</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">close_files</span><span style="color: #0000FF;">()</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
<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>
<!--</syntaxhighlight>-->
{{out}}
<pre>
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|Python}}==
Tested with Python 2.7 and 3.x
<
import sys, shlex, operator
Line 550 ⟶ 5,106:
elif x.node_type == nd_Prts:
print(interp(x.left
return None
Line 559 ⟶ 5,115:
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]
Line 576 ⟶ 5,150:
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()
Line 590 ⟶ 5,167:
n = load_ast()
interp(n)</
{{out|case=prime numbers output from AST interpreter}}
Line 624 ⟶ 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}}==
The complete implementation for the compiler tasks can be found in a GitHub repository at [https://github.com/edadma/rosettacodeCompiler 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 [http://rosettacode.org/wiki/Compiler/syntax_analyzer#Scala parser].
<syntaxhighlight lang="scala">
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
}
</syntaxhighlight>
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.
<syntaxhighlight lang="scala">
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
}
}
</syntaxhighlight>
=={{header|Scheme}}==
<syntaxhighlight lang="scheme">
(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"))
</syntaxhighlight>
{{out}}
Output for primes program from above. Also tested on programs in [[Compiler/Sample programs]].
<pre>
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|Wren}}==
{{trans|Go}}
{{libheader|Wren-dynamic}}
{{libheader|Wren-fmt}}
{{libheader|Wren-ioutil}}
<syntaxhighlight lang="wren">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)</syntaxhighlight>
{{out}}
<pre>
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>
{{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}}==
<syntaxhighlight lang="zig">
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 => _ = 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}", .{@as(u8, @intCast((try self.interp(t.left)).?.integer))}),
.string => return t.value,
.integer => return t.value,
.unknown => {
std.debug.print("\nINTERP: UNKNOWN {}\n", .{t});
std.os.exit(1);
},
}
}
return null;
}
pub fn out(self: *Self, comptime format: []const u8, args: anytype) ASTInterpreterError!void {
try self.output.writer().print(format, args);
}
fn binOp(
self: *Self,
comptime func: fn (a: i32, b: i32) i32,
a: ?*Tree,
b: ?*Tree,
) ASTInterpreterError!i32 {
return func(
(try self.interp(a)).?.integer,
(try self.interp(b)).?.integer,
);
}
fn less(a: i32, b: i32) i32 {
return @intFromBool(a < b);
}
fn less_equal(a: i32, b: i32) i32 {
return @intFromBool(a <= b);
}
fn greater(a: i32, b: i32) i32 {
return @intFromBool(a > b);
}
fn greater_equal(a: i32, b: i32) i32 {
return @intFromBool(a >= b);
}
fn equal(a: i32, b: i32) i32 {
return @intFromBool(a == b);
}
fn not_equal(a: i32, b: i32) i32 {
return @intFromBool(a != b);
}
fn add(a: i32, b: i32) i32 {
return a + b;
}
fn sub(a: i32, b: i32) i32 {
return a - b;
}
fn mul(a: i32, b: i32) i32 {
return a * b;
}
fn div(a: i32, b: i32) i32 {
return @divTrunc(a, b);
}
fn mod(a: i32, b: i32) i32 {
return @mod(a, b);
}
fn @"or"(a: i32, b: i32) i32 {
return @intFromBool((a != 0) or (b != 0));
}
fn @"and"(a: i32, b: i32) i32 {
return @intFromBool((a != 0) and (b != 0));
}
};
pub fn main() !void {
var arena = std.heap.ArenaAllocator.init(std.heap.page_allocator);
defer arena.deinit();
const allocator = arena.allocator();
var arg_it = try std.process.argsWithAllocator(allocator);
_ = arg_it.next() orelse unreachable; // program name
const file_name = arg_it.next();
// We accept both files and standard input.
var file_handle = blk: {
if (file_name) |file_name_delimited| {
const fname: []const u8 = file_name_delimited;
break :blk try std.fs.cwd().openFile(fname, .{});
} else {
break :blk std.io.getStdIn();
}
};
defer file_handle.close();
const input_content = try file_handle.readToEndAlloc(allocator, std.math.maxInt(usize));
var string_pool = std.ArrayList([]const u8).init(allocator);
const ast = try loadAST(allocator, input_content, &string_pool);
var ast_interpreter = ASTInterpreter.init(allocator);
_ = try ast_interpreter.interp(ast);
const result: []const u8 = ast_interpreter.output.items;
_ = try std.io.getStdOut().write(result);
}
pub const NodeType = enum {
unknown,
identifier,
string,
integer,
sequence,
kw_if,
prtc,
prts,
prti,
kw_while,
assign,
negate,
not,
multiply,
divide,
mod,
add,
subtract,
less,
less_equal,
greater,
greater_equal,
equal,
not_equal,
bool_and,
bool_or,
const from_string_map = std.ComptimeStringMap(NodeType, .{
.{ "UNKNOWN", .unknown },
.{ "Identifier", .identifier },
.{ "String", .string },
.{ "Integer", .integer },
.{ "Sequence", .sequence },
.{ "If", .kw_if },
.{ "Prtc", .prtc },
.{ "Prts", .prts },
.{ "Prti", .prti },
.{ "While", .kw_while },
.{ "Assign", .assign },
.{ "Negate", .negate },
.{ "Not", .not },
.{ "Multiply", .multiply },
.{ "Divide", .divide },
.{ "Mod", .mod },
.{ "Add", .add },
.{ "Subtract", .subtract },
.{ "Less", .less },
.{ "LessEqual", .less_equal },
.{ "Greater", .greater },
.{ "GreaterEqual", .greater_equal },
.{ "Equal", .equal },
.{ "NotEqual", .not_equal },
.{ "And", .bool_and },
.{ "Or", .bool_or },
});
pub fn fromString(str: []const u8) NodeType {
return from_string_map.get(str).?;
}
};
pub const NodeValue = union(enum) {
integer: i32,
string: []const u8,
};
pub const Tree = struct {
left: ?*Tree,
right: ?*Tree,
typ: NodeType = .unknown,
value: ?NodeValue = null,
fn makeNode(allocator: std.mem.Allocator, typ: NodeType, left: ?*Tree, right: ?*Tree) !*Tree {
const result = try allocator.create(Tree);
result.* = Tree{ .left = left, .right = right, .typ = typ };
return result;
}
fn makeLeaf(allocator: std.mem.Allocator, typ: NodeType, value: ?NodeValue) !*Tree {
const result = try allocator.create(Tree);
result.* = Tree{ .left = null, .right = null, .typ = typ, .value = value };
return result;
}
};
const LoadASTError = error{OutOfMemory} || std.fmt.ParseIntError;
fn loadAST(
allocator: std.mem.Allocator,
str: []const u8,
string_pool: *std.ArrayList([]const u8),
) LoadASTError!?*Tree {
var line_it = std.mem.split(u8, str, "\n");
return try loadASTHelper(allocator, &line_it, string_pool);
}
fn loadASTHelper(
allocator: std.mem.Allocator,
line_it: *std.mem.SplitIterator(u8, std.mem.DelimiterType.sequence),
string_pool: *std.ArrayList([]const u8),
) LoadASTError!?*Tree {
if (line_it.next()) |line| {
var tok_it = std.mem.tokenize(u8, line, " ");
const tok_str = tok_it.next().?;
if (tok_str[0] == ';') return null;
const node_type = NodeType.fromString(tok_str);
const pre_iteration_index = tok_it.index;
if (tok_it.next()) |leaf_value| {
const node_value = blk: {
switch (node_type) {
.integer => break :blk NodeValue{ .integer = try std.fmt.parseInt(i32, leaf_value, 10) },
.identifier => break :blk NodeValue{ .string = leaf_value },
.string => {
tok_it.index = pre_iteration_index;
const str = tok_it.rest();
var string_literal = try std.ArrayList(u8).initCapacity(allocator, str.len);
var escaped = false;
// Truncate double quotes
for (str[1 .. str.len - 1]) |ch| {
if (escaped) {
escaped = false;
switch (ch) {
'n' => try string_literal.append('\n'),
'\\' => try string_literal.append('\\'),
else => unreachable,
}
} else {
switch (ch) {
'\\' => escaped = true,
else => try string_literal.append(ch),
}
}
}
try string_pool.append(string_literal.items);
break :blk NodeValue{ .string = string_literal.items };
},
else => unreachable,
}
};
return try Tree.makeLeaf(allocator, node_type, node_value);
}
const left = try loadASTHelper(allocator, line_it, string_pool);
const right = try loadASTHelper(allocator, line_it, string_pool);
return try Tree.makeNode(allocator, node_type, left, right);
} else {
return null;
}
}
</syntaxhighlight>
=={{header|zkl}}==
<syntaxhighlight 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,
AND=N, OR=N, NEG=N, NOT=N,
JMP=N, JZ=N, PRTC=N, PRTS=N, PRTI=N, HALT=N;
const nd_String=N, nd_Sequence=N, nd_If=N, nd_While=N;
var [const]
all_syms=Dictionary(
"Identifier" ,FETCH, "String" ,nd_String,
"Integer" ,PUSH, "Sequence" ,nd_Sequence,
"If" ,nd_If, "Prtc" ,PRTC,
"Prts" ,PRTS, "Prti" ,PRTI,
"While" ,nd_While, "Assign" ,STORE,
"Negate" ,NEG, "Not" ,NOT,
"Multiply" ,MUL, "Divide" ,DIV,
"Mod" ,MOD, "Add" ,ADD,
"Subtract" ,SUB, "Less" ,LT,
"LessEqual" ,LE, "Greater" ,GT,
"GreaterEqual",GE, "Equal" ,EQ,
"NotEqual" ,NE, "And" ,AND,
"Or" ,OR, "halt" ,HALT),
bops=Dictionary(ADD,'+, SUB,'-, MUL,'*, DIV,'/, MOD,'%,
LT,'<, GT,'>, LE,'<=, GE,'>=, NE,'!=, EQ,'==, NE,'!=);
class Node{
fcn init(_node_type, _value, _left=Void, _right=Void){
var type=_node_type, left=_left, right=_right, value=_value;
}
}
fcn runNode(node){
var vars=Dictionary(); // fcn local static var
if(Void==node) return();
switch(node.type){
case(PUSH,nd_String){ return(node.value) }
case(FETCH){ return(vars[node.value]) }
case(STORE){ vars[node.left.value]=runNode(node.right); return(Void); }
case(nd_If){
if(runNode(node.left)) runNode(node.right.left);
else runNode(node.right.right);
}
case(nd_While)
{ while(runNode(node.left)){ runNode(node.right) } return(Void) }
case(nd_Sequence){ runNode(node.left); runNode(node.right); return(Void) }
case(PRTC) { print(runNode(node.left).toAsc()) }
case(PRTI,PRTS) { print(runNode(node.left)) }
case(NEG) { return(-runNode(node.left)) }
case(NOT) { return(not runNode(node.left)) }
case(AND) { return(runNode(node.left) and runNode(node.right)) }
case(OR) { return(runNode(node.left) or runNode(node.right)) }
else{
if(op:=bops.find(node.type))
return(op(runNode(node.left),runNode(node.right)));
else throw(Exception.AssertionError(
"Unknown node type: %d".fmt(node.type)))
}
}
Void
}</syntaxhighlight>
<syntaxhighlight lang="zkl">fcn load_ast(file){
line:=file.readln().strip(); // one or two tokens
if(line[0]==";") return(Void);
parts,type,value := line.split(),parts[0],parts[1,*].concat(" ");
type=all_syms[type];
if(value){
try{ value=value.toInt() }catch{}
if(type==nd_String) value=value[1,-1].replace("\\n","\n");
return(Node(type,value));
}
left,right := load_ast(file),load_ast(file);
Node(type,Void,left,right)
}</syntaxhighlight>
<syntaxhighlight lang="zkl">ast:=load_ast(File(vm.nthArg(0)));
runNode(ast);</syntaxhighlight>
{{out}}
<pre>
$ zkl runAST.zkl primeAST.txt
3 is prime
5 is prime
7 is prime
11 is prime
...
89 is prime
97 is prime
101 is prime
Total primes found: 26
</pre>
| |||