modules/lang/forth.zzm

=encoding utf8

=head1 NAME

lang/forth - Interpret ANS Forth-style source.

=head1 SYNOPSIS

  from lang/forth import forth, forth_system;

  say( forth(": square dup * ; 9 square .") );  # 81 

  let system := forth_system();
  system.evaluate("variable x 41 x ! x @ 1+ .");
  say( system.output() );                       # 42 

=head1 DESCRIPTION

This module implements a small pure-Zuzu ANS Forth-oriented interpreter.
It provides the ordinary data stack, return stack, dictionary, colon
definitions, variables, constants, values, memory cells, output capture,
and a practical Core word set.

The implementation is intended for embedding Forth snippets and scripts
inside ZuzuScript applications. It is not a native-code Forth system and
does not expose implementation-defined address arithmetic beyond the
managed cell store used by C<@>, C<!>, C<,>, and related words.

=head1 EXPORTS

=over

=item C<forth(String source, Dict options?)>

Evaluates C<source> in a new C<ForthSystem> and returns captured output.

=item C<forth_system(Dict options?)>

Returns a fresh C<ForthSystem> with the standard dictionary installed.

=item C<parse_forth(String source, String source_name?)>

Tokenizes source text and returns C<ForthToken> values.

=back

=head1 COPYRIGHT AND LICENCE

B<< lang/forth >> is copyright Toby Inkster.

It is free software; you may redistribute it and/or modify it under the
terms of either the Artistic License 1.0 or the GNU General Public License
version 2.

=cut

from std/string import chr, index, join, ord, substr;

function _execute_tokens;
function _run_body;
function _install_core;
function parse_forth;
function _array_contains;

class ForthError extends Exception {
	let String source_name with get := "<string>";
	let Number line with get := 0;
	let Number column with get := 0;

	method to_String () {
		if ( self{line} > 0 ) {
			return self{message} _ " at " _ self{source_name} _ ":" _
				self{line} _ ":" _ self{column};
		}
		return self{message};
	}
}

class ForthSyntaxError extends ForthError;
class ForthRuntimeError extends ForthError;

class ForthToken {
	let String text with get := "";
	let String string_value with get := "";
	let String source_name with get := "<string>";
	let Number line with get := 1;
	let Number column with get := 1;

	method word () {
		return uc(text);
	}
}

class ForthWord {
	let String name with get := "";
	let String kind with get := "primitive";
	let callback with get := null;
	let Array body with get := [];
	let value with get := null;
	let Boolean compile_only with get := false;

	method __build__ () {
		body := [] if body == null;
	}
}

class ForthSystem {
	let Array stack with get := [];
	let Array return_stack with get := [];
	let Array loop_stack with get := [];
	let Dict dictionary with get := {};
	let Array word_order with get := [];
	let Array memory with get := [];
	let Number here with get := 0;
	let Number base with get := 10;
	let Array output_buffer with get := [];
	let output_callback with get := null;
	let Boolean compiling with get := false;
	let String current_name with get := "";
	let Array current_body with get := [];
	let String source_name with get := "<string>";

	method __build__ () {
		stack := [] if stack == null;
		return_stack := [] if return_stack == null;
		loop_stack := [] if loop_stack == null;
		dictionary := {} if dictionary == null;
		word_order := [] if word_order == null;
		memory := [] if memory == null;
		output_buffer := [] if output_buffer == null;
		current_body := [] if current_body == null;
		_install_core(self);
	}

	method set_base ( Number new_base ) {
		if ( new_base < 2 or new_base > 36 ) {
			self.runtime_error("BASE must be between 2 and 36");
		}
		base := new_base;
		return base;
	}

	method define_primitive ( String name, Function callback ) {
		return self.define_word(
			new ForthWord(
				name: uc(name),
				kind: "primitive",
				callback: callback,
			),
		);
	}

	method define_user ( String name, Array body ) {
		return self.define_word(
			new ForthWord( name: uc(name), kind: "user", body: body ),
		);
	}

	method define_constant ( String name, value ) {
		return self.define_word(
			new ForthWord( name: uc(name), kind: "constant", value: value ),
		);
	}

	method define_variable ( String name, value := 0 ) {
		let address := here;
		memory.push(value);
		here++;
		self.define_word(
			new ForthWord( name: uc(name), kind: "variable", value: address ),
		);
		return address;
	}

	method define_value ( String name, value ) {
		return self.define_word(
			new ForthWord( name: uc(name), kind: "value", value: value ),
		);
	}

	method define_word ( ForthWord word ) {
		let name := uc(word.get_name());
		dictionary.set( name, word );
		word_order.push(name);
		return word;
	}

	method lookup ( String name ) {
		let key := uc(name);
		return dictionary.get(key) if dictionary.exists(key);
		return null;
	}

	method require_word ( String name ) {
		let word := self.lookup(name);
		return word if word != null;
		self.runtime_error("Undefined word: " _ name);
	}

	method push ( value ) {
		stack.push(value);
		return value;
	}

	method pop () {
		self.runtime_error("Stack underflow") if stack.length() == 0;
		return stack.pop();
	}

	method peek ( Number depth := 0 ) {
		let pos := stack.length() - 1 - depth;
		self.runtime_error("Stack underflow") if pos < 0;
		return stack[pos];
	}

	method rpush ( value ) {
		return_stack.push(value);
		return value;
	}

	method rpop () {
		self.runtime_error("Return stack underflow") if return_stack.length() == 0;
		return return_stack.pop();
	}

	method rpeek () {
		self.runtime_error("Return stack underflow") if return_stack.length() == 0;
		return return_stack[ return_stack.length() - 1 ];
	}

	method output_text ( String text ) {
		if ( output_callback != null ) {
			output_callback(text);
		}
		else {
			output_buffer.push(text);
		}
		return text;
	}

	method output () {
		return join( "", output_buffer );
	}

	method clear_output () {
		output_buffer := [];
		return self;
	}

	method evaluate ( String source, String name := "<string>" ) {
		source_name := name;
		_execute_tokens( self, parse_forth( source, name ) );
		if ( compiling ) {
			self.syntax_error("Unterminated colon definition");
		}
		return self;
	}

	method execute_word ( ForthWord word ) {
		if ( word.get_kind() eq "primitive" ) {
			return word.get_callback()(self);
		}
		if ( word.get_kind() eq "user" ) {
			return _run_body( self, word.get_body() );
		}
		if ( word.get_kind() eq "constant" or word.get_kind() eq "value" ) {
			return self.push(word.get_value());
		}
		if ( word.get_kind() eq "variable" ) {
			return self.push(word.get_value());
		}
		self.runtime_error("Unsupported word kind: " _ word.get_kind());
	}

	method syntax_error ( String message, token? ) {
		if ( token instanceof ForthToken ) {
			throw new ForthSyntaxError(
				message: message,
				source_name: token.get_source_name(),
				line: token.get_line(),
				column: token.get_column(),
			);
		}
		throw new ForthSyntaxError(
			message: message,
			source_name: source_name,
		);
	}

	method runtime_error ( String message, token? ) {
		if ( token instanceof ForthToken ) {
			throw new ForthRuntimeError(
				message: message,
				source_name: token.get_source_name(),
				line: token.get_line(),
				column: token.get_column(),
			);
		}
		throw new ForthRuntimeError(
			message: message,
			source_name: source_name,
		);
	}
}

function _option ( options, String key, fallback ) {
	if ( typeof options == "Dict" and options.exists(key) ) {
		return options.get(key);
	}
	return fallback;
}

function _is_space ( String ch ) {
	return ch eq " " or ch eq "\n" or ch eq "\t" or ch eq "\r";
}

function _advance_position ( String ch, Dict pos ) {
	if ( ch eq "\n" ) {
		pos{line}++;
		pos{column} := 1;
	}
	else {
		pos{column}++;
	}
	pos{index}++;
}

function _skip_to_eol ( String source, Dict pos ) {
	while ( pos{index} < length source ) {
		let ch := substr( source, pos{index}, 1 );
		_advance_position( ch, pos );
		last if ch eq "\n";
	}
}

function _skip_paren_comment ( String source, Dict pos ) {
	while ( pos{index} < length source ) {
		let ch := substr( source, pos{index}, 1 );
		_advance_position( ch, pos );
		return true if ch eq ")";
	}
	return false;
}

function _read_quoted ( String source, Dict pos ) {
	let value := "";
	while ( pos{index} < length source ) {
		let ch := substr( source, pos{index}, 1 );
		_advance_position( ch, pos );
		return value if ch eq "\"";
		if ( ch eq "\\" and pos{index} < length source ) {
			let nxt := substr( source, pos{index}, 1 );
			_advance_position( nxt, pos );
			if ( nxt eq "n" ) {
				value _= "\n";
			}
			else if ( nxt eq "t" ) {
				value _= "\t";
			}
			else if ( nxt eq "r" ) {
				value _= "\r";
			}
			else {
				value _= nxt;
			}
		}
		else {
			value _= ch;
		}
	}
	return null;
}

function parse_forth (
	String source,
	String source_name := "<string>",
) {
	let tokens := [];
	let pos := { index: 0, line: 1, column: 1 };

	while ( pos{index} < length source ) {
		let ch := substr( source, pos{index}, 1 );

		if ( _is_space(ch) ) {
			_advance_position( ch, pos );
		}
		else if ( ch eq "\\" ) {
			_skip_to_eol( source, pos );
		}
		else if ( ch eq "(" ) {
			let line := pos{line};
			let column := pos{column};
			_advance_position( ch, pos );
			if ( not _skip_paren_comment( source, pos ) ) {
				throw new ForthSyntaxError(
					message: "Unterminated parenthesized comment",
					source_name: source_name,
					line: line,
					column: column,
				);
			}
		}
		else {
			let line := pos{line};
			let column := pos{column};
			let text := "";

			while ( pos{index} < length source ) {
				ch := substr( source, pos{index}, 1 );
				last if _is_space(ch);
				text _= ch;
				_advance_position( ch, pos );
			}

			let word := uc(text);
			let string_value := "";
			if ( word eq ".\"" or word eq "S\"" or word eq "C\"" or
				word eq "ABORT\"" ) {
				if (
					pos{index} < length source and
					substr( source, pos{index}, 1 ) eq " "
				) {
					_advance_position( " ", pos );
				}
				let read := _read_quoted( source, pos );
				if ( read == null ) {
					throw new ForthSyntaxError(
						message: "Unterminated string literal",
						source_name: source_name,
						line: line,
						column: column,
					);
				}
				string_value := read;
			}

			tokens.push(
				new ForthToken(
					text: text,
					string_value: string_value,
					source_name: source_name,
					line: line,
					column: column,
				),
			);
		}
	}

	return tokens;
}

function _truth ( value ) {
	if ( typeof value == "Boolean" ) {
		return value ? -1 : 0;
	}
	return value == 0 ? 0 : -1;
}

function _num ( value ) {
	return value + 0 if typeof value == "Number";
	return ( "" _ value ) + 0 if ( "" _ value ) ~ /^[+-]?\d+$/;
	return value + 0;
}

function _digit_value ( String ch ) {
	return index( "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ", uc(ch) );
}

function _parse_number ( String text, Number base ) {
	let sign := 1;
	let i := 0;
	if ( text eq "" ) {
		return null;
	}
	if ( substr( text, 0, 1 ) eq "-" ) {
		sign := -1;
		i := 1;
	}
	else if ( substr( text, 0, 1 ) eq "+" ) {
		i := 1;
	}
	return null if i >= length text;

	let n := 0;
	while ( i < length text ) {
		let d := _digit_value( substr( text, i, 1 ) );
		return null if d < 0 or d >= base;
		n := n * base + d;
		i++;
	}
	return sign * n;
}

function _store_at ( ForthSystem sys, Number address, value ) {
	sys.runtime_error("Invalid memory address") if address < 0;
	if (
		sys.get_dictionary().exists("__BASE_ADDR") and
		address == sys.get_dictionary().get("__BASE_ADDR").get_value()
	) {
		sys.set_base(value);
	}
	while ( address >= sys.get_memory().length() ) {
		sys.get_memory().push(0);
	}
	sys.get_memory()[address] := value;
	return value;
}

function _fetch_at ( ForthSystem sys, Number address ) {
	sys.runtime_error("Invalid memory address") if address < 0;
	while ( address >= sys.get_memory().length() ) {
		sys.get_memory().push(0);
	}
	return sys.get_memory()[address];
}

function _next_name ( ForthSystem sys, Array tokens, Number ip, String word ) {
	sys.syntax_error( word _ " requires a following name", tokens[ip] )
		if ip + 1 >= tokens.length();
	return tokens[ip + 1].get_text();
}

function _execute_normal_token (
	ForthSystem sys,
	ForthToken token,
	Array tokens,
	Number ip,
) {
	let name := token.word();

	if ( name eq ":" ) {
		let new_name := _next_name( sys, tokens, ip, ":" );
		sys{compiling} := true;
		sys{current_name} := new_name;
		sys{current_body} := [];
		return ip + 2;
	}
	if ( name eq "VARIABLE" ) {
		sys.define_variable( _next_name( sys, tokens, ip, "VARIABLE" ) );
		return ip + 2;
	}
	if ( name eq "CONSTANT" ) {
		sys.define_constant( _next_name( sys, tokens, ip, "CONSTANT" ), sys.pop() );
		return ip + 2;
	}
	if ( name eq "VALUE" ) {
		sys.define_value( _next_name( sys, tokens, ip, "VALUE" ), sys.pop() );
		return ip + 2;
	}
	if ( name eq "TO" ) {
		let word := sys.require_word( _next_name( sys, tokens, ip, "TO" ) );
		if ( word.get_kind() ne "value" ) {
			sys.runtime_error("TO requires a VALUE", token);
		}
		word{value} := sys.pop();
		return ip + 2;
	}
	if ( name eq "CHAR" or name eq "[CHAR]" ) {
		let raw := _next_name( sys, tokens, ip, name );
		sys.push( ord( raw, 0 ) );
		return ip + 2;
	}

	if ( name eq ".\"" ) {
		sys.output_text(token.get_string_value());
		return ip + 1;
	}
	if ( name eq "S\"" or name eq "C\"" ) {
		sys.push(token.get_string_value());
		return ip + 1;
	}
	if ( name eq "ABORT\"" ) {
		if ( sys.pop() != 0 ) {
			sys.runtime_error(token.get_string_value(), token);
		}
		return ip + 1;
	}

	let word := sys.lookup(name);
	if ( word != null ) {
		sys.execute_word(word);
		return ip + 1;
	}

	let number := _parse_number( token.get_text(), sys.get_base() );
	if ( number != null ) {
		sys.push(number);
		return ip + 1;
	}

	sys.runtime_error("Undefined word: " _ token.get_text(), token);
}

function _execute_tokens ( ForthSystem sys, Array tokens ) {
	let ip := 0;
	while ( ip < tokens.length() ) {
		let token := tokens[ip];
		if ( sys.get_compiling() ) {
			if ( token.word() eq ";" ) {
				sys.define_user( sys.get_current_name(), sys.get_current_body() );
				sys{compiling} := false;
				sys{current_name} := "";
				sys{current_body} := [];
			}
			else {
				sys.get_current_body().push(token);
			}
			ip++;
		}
		else {
			ip := _execute_normal_token( sys, token, tokens, ip );
		}
	}
}

function _find_forward (
	Array body,
	Number ip,
	Array targets,
	Array opens,
) {
	let depth := 0;
	let i := ip + 1;
	while ( i < body.length() ) {
		let word := body[i].word();
		if ( _array_contains( opens, word ) ) {
			depth++;
		}
		else if ( _array_contains( targets, word ) ) {
			return i if depth == 0;
			depth--;
		}
		i++;
	}
	return -1;
}

function _find_backward (
	Array body,
	Number ip,
	String target,
	Array closers,
) {
	let depth := 0;
	let i := ip - 1;
	while ( i >= 0 ) {
		let word := body[i].word();
		if ( _array_contains( closers, word ) ) {
			depth++;
		}
		else if ( word eq target ) {
			return i if depth == 0;
			depth--;
		}
		i--;
	}
	return -1;
}

function _array_contains ( Array values, value ) {
	for ( let item in values ) {
		return true if item == value;
	}
	return false;
}

function _loop_done ( Number old_index, Number new_index, Number limit,
Number step ) {
	if ( step >= 0 ) {
		return new_index >= limit;
	}
	return new_index < limit;
}

function _execute_body_token (
	ForthSystem sys,
	Array body,
	Number ip,
) {
	let token := body[ip];
	let name := token.word();

	if ( name eq "IF" ) {
		if ( sys.pop() == 0 ) {
			let target := _find_forward( body, ip, [ "ELSE", "THEN" ], [ "IF" ] );
			sys.syntax_error("IF without THEN", token) if target < 0;
			return body[target].word() eq "ELSE" ? target + 1 : target + 1;
		}
		return ip + 1;
	}
	if ( name eq "ELSE" ) {
		let target := _find_forward( body, ip, [ "THEN" ], [ "IF" ] );
		sys.syntax_error("ELSE without THEN", token) if target < 0;
		return target + 1;
	}
	if ( name eq "THEN" ) {
		return ip + 1;
	}
	if ( name eq "BEGIN" ) {
		return ip + 1;
	}
	if ( name eq "UNTIL" ) {
		if ( sys.pop() == 0 ) {
			let target := _find_backward(
				body,
				ip,
				"BEGIN",
				[ "UNTIL", "AGAIN", "REPEAT" ],
			);
			sys.syntax_error("UNTIL without BEGIN", token) if target < 0;
			return target + 1;
		}
		return ip + 1;
	}
	if ( name eq "AGAIN" ) {
		let target := _find_backward(
			body,
			ip,
			"BEGIN",
			[ "UNTIL", "AGAIN", "REPEAT" ],
		);
		sys.syntax_error("AGAIN without BEGIN", token) if target < 0;
		return target + 1;
	}
	if ( name eq "WHILE" ) {
		if ( sys.pop() == 0 ) {
			let target := _find_forward(
				body,
				ip,
				[ "REPEAT" ],
				[ "BEGIN", "WHILE" ],
			);
			sys.syntax_error("WHILE without REPEAT", token) if target < 0;
			return target + 1;
		}
		return ip + 1;
	}
	if ( name eq "REPEAT" ) {
		let target := _find_backward(
			body,
			ip,
			"BEGIN",
			[ "UNTIL", "AGAIN", "REPEAT" ],
		);
		sys.syntax_error("REPEAT without BEGIN", token) if target < 0;
		return target + 1;
	}
	if ( name eq "DO" ) {
		let limit := sys.pop();
		let start := sys.pop();
		sys.get_loop_stack().push( { index: start, limit: limit, start_ip: ip } );
		return ip + 1;
	}
	if ( name eq "LOOP" or name eq "+LOOP" ) {
		sys.runtime_error("LOOP without DO", token)
			if sys.get_loop_stack().length() == 0;
		let step := name eq "LOOP" ? 1 : sys.pop();
		let frame := sys.get_loop_stack()[ sys.get_loop_stack().length() - 1 ];
		let old_index := frame{index};
		frame{index} += step;
		if ( _loop_done( old_index, frame{index}, frame{limit}, step ) ) {
			sys.get_loop_stack().pop();
			return ip + 1;
		}
		return frame{start_ip} + 1;
	}
	if ( name eq "I" or name eq "J" ) {
		let depth := name eq "I" ? 0 : 1;
		let pos := sys.get_loop_stack().length() - 1 - depth;
		sys.runtime_error(name _ " outside DO loop", token) if pos < 0;
		sys.push( sys.get_loop_stack()[pos]{index} );
		return ip + 1;
	}
	if ( name eq "LEAVE" ) {
		sys.runtime_error("LEAVE outside DO loop", token)
			if sys.get_loop_stack().length() == 0;
		sys.get_loop_stack().pop();
		let target := _find_forward( body, ip, [ "LOOP", "+LOOP" ], [ "DO" ] );
		sys.syntax_error("LEAVE without LOOP", token) if target < 0;
		return target + 1;
	}

	return _execute_normal_token( sys, token, body, ip );
}

function _run_body ( ForthSystem sys, Array body ) {
	let saved_compiling := sys.get_compiling();
	sys{compiling} := false;
	let ip := 0;
	while ( ip < body.length() ) {
		ip := _execute_body_token( sys, body, ip );
	}
	sys{compiling} := saved_compiling;
	return sys;
}

function _binop ( ForthSystem sys, Function f ) {
	let b := sys.pop();
	let a := sys.pop();
	return sys.push( f( a, b ) );
}

function _cmpop ( ForthSystem sys, Function f ) {
	let b := sys.pop();
	let a := sys.pop();
	return sys.push( f( a, b ) ? -1 : 0 );
}

function _spaces ( Number count ) {
	let out := "";
	let i := 0;
	while ( i < count ) {
		out _= " ";
		i++;
	}
	return out;
}

function _install_core ( ForthSystem sys ) {
	let base_address := sys.define_variable( "__BASE_ADDR", sys.get_base() );
	sys.define_word(
		new ForthWord( name: "BASE", kind: "variable", value: base_address ),
	);

	sys.define_primitive( "DROP", function ( s ) { s.pop(); return s; } );
	sys.define_primitive( "DUP", function ( s ) { return s.push(s.peek()); } );
	sys.define_primitive( "?DUP", function ( s ) {
		let x := s.peek();
		s.push(x) if x != 0;
		return s;
	} );
	sys.define_primitive( "SWAP", function ( s ) {
		let b := s.pop();
		let a := s.pop();
		s.push(b);
		s.push(a);
		return s;
	} );
	sys.define_primitive( "OVER", function ( s ) { return s.push(s.peek(1)); } );
	sys.define_primitive( "ROT", function ( s ) {
		let c := s.pop();
		let b := s.pop();
		let a := s.pop();
		s.push(b);
		s.push(c);
		s.push(a);
		return s;
	} );
	sys.define_primitive( "-ROT", function ( s ) {
		let c := s.pop();
		let b := s.pop();
		let a := s.pop();
		s.push(c);
		s.push(a);
		s.push(b);
		return s;
	} );
	sys.define_primitive( "NIP", function ( s ) {
		let b := s.pop();
		s.pop();
		return s.push(b);
	} );
	sys.define_primitive( "TUCK", function ( s ) {
		let b := s.pop();
		let a := s.pop();
		s.push(b);
		s.push(a);
		s.push(b);
		return s;
	} );
	sys.define_primitive( "DEPTH", function ( s ) {
		return s.push(s.get_stack().length());
	} );
	sys.define_primitive( "2DROP", function ( s ) {
		s.pop();
		s.pop();
		return s;
	} );
	sys.define_primitive( "2DUP", function ( s ) {
		let b := s.peek();
		let a := s.peek(1);
		s.push(a);
		s.push(b);
		return s;
	} );
	sys.define_primitive( "2OVER", function ( s ) {
		let b := s.peek(2);
		let a := s.peek(3);
		s.push(a);
		s.push(b);
		return s;
	} );
	sys.define_primitive( "2SWAP", function ( s ) {
		let d := s.pop();
		let c := s.pop();
		let b := s.pop();
		let a := s.pop();
		s.push(c);
		s.push(d);
		s.push(a);
		s.push(b);
		return s;
	} );

	sys.define_primitive( ">R", function ( s ) { return s.rpush(s.pop()); } );
	sys.define_primitive( "R>", function ( s ) { return s.push(s.rpop()); } );
	sys.define_primitive( "R@", function ( s ) { return s.push(s.rpeek()); } );

	sys.define_primitive( "+", function ( s ) {
		return _binop( s, function ( a, b ) { return a + b; } );
	} );
	sys.define_primitive( "-", function ( s ) {
		return _binop( s, function ( a, b ) { return a - b; } );
	} );
	sys.define_primitive( "*", function ( s ) {
		return _binop( s, function ( a, b ) { return a * b; } );
	} );
	sys.define_primitive( "/", function ( s ) {
		return _binop( s, function ( a, b ) {
			s.runtime_error("Division by zero") if b == 0;
			return int(a / b);
		} );
	} );
	sys.define_primitive( "MOD", function ( s ) {
		return _binop( s, function ( a, b ) {
			s.runtime_error("Division by zero") if b == 0;
			return a mod b;
		} );
	} );
	sys.define_primitive( "/MOD", function ( s ) {
		let b := s.pop();
		let a := s.pop();
		s.runtime_error("Division by zero") if b == 0;
		s.push(a mod b);
		s.push(int(a / b));
		return s;
	} );
	sys.define_primitive( "1+", function ( s ) { return s.push(s.pop() + 1); } );
	sys.define_primitive( "1-", function ( s ) { return s.push(s.pop() - 1); } );
	sys.define_primitive( "2*", function ( s ) { return s.push(s.pop() * 2); } );
	sys.define_primitive( "2/", function ( s ) { return s.push(int(s.pop() / 2)); } );
	sys.define_primitive( "NEGATE", function ( s ) { return s.push(0 - s.pop()); } );
	sys.define_primitive( "ABS", function ( s ) {
		let x := s.pop();
		return s.push( x < 0 ? 0 - x : x );
	} );
	sys.define_primitive( "MIN", function ( s ) {
		return _binop( s, function ( a, b ) { return a < b ? a : b; } );
	} );
	sys.define_primitive( "MAX", function ( s ) {
		return _binop( s, function ( a, b ) { return a > b ? a : b; } );
	} );

	sys.define_primitive( "=", function ( s ) {
		return _cmpop( s, function ( a, b ) { return a == b; } );
	} );
	sys.define_primitive( "<>", function ( s ) {
		return _cmpop( s, function ( a, b ) { return a != b; } );
	} );
	sys.define_primitive( "<", function ( s ) {
		return _cmpop( s, function ( a, b ) { return a < b; } );
	} );
	sys.define_primitive( ">", function ( s ) {
		return _cmpop( s, function ( a, b ) { return a > b; } );
	} );
	sys.define_primitive( "<=", function ( s ) {
		return _cmpop( s, function ( a, b ) { return a <= b; } );
	} );
	sys.define_primitive( ">=", function ( s ) {
		return _cmpop( s, function ( a, b ) { return a >= b; } );
	} );
	sys.define_primitive( "0=", function ( s ) { return s.push(_truth(s.pop() == 0)); } );
	sys.define_primitive( "0<", function ( s ) { return s.push(_truth(s.pop() < 0)); } );
	sys.define_primitive( "0>", function ( s ) { return s.push(_truth(s.pop() > 0)); } );
	sys.define_primitive( "WITHIN", function ( s ) {
		let high := s.pop();
		let low := s.pop();
		let x := s.pop();
		return s.push( x >= low and x < high ? -1 : 0 );
	} );
	sys.define_primitive( "AND", function ( s ) {
		return _binop( s, function ( a, b ) {
			return ( a != 0 and b != 0 ) ? -1 : 0;
		} );
	} );
	sys.define_primitive( "OR", function ( s ) {
		return _binop( s, function ( a, b ) {
			return ( a != 0 or b != 0 ) ? -1 : 0;
		} );
	} );
	sys.define_primitive( "XOR", function ( s ) {
		return _binop( s, function ( a, b ) {
			return ( ( a != 0 ) != ( b != 0 ) ) ? -1 : 0;
		} );
	} );
	sys.define_primitive( "INVERT", function ( s ) {
		return s.push( s.pop() == 0 ? -1 : 0 );
	} );

	sys.define_primitive( ".", function ( s ) {
		s.output_text( "" _ s.pop() _ " " );
		return s;
	} );
	sys.define_primitive( ".S", function ( s ) {
		s.output_text( "<" _ s.get_stack().length() _ "> " );
		for ( let item in s.get_stack() ) {
			s.output_text( "" _ item _ " " );
		}
		return s;
	} );
	sys.define_primitive( "EMIT", function ( s ) {
		s.output_text(chr(s.pop()));
		return s;
	} );
	sys.define_primitive( "CR", function ( s ) {
		s.output_text("\n");
		return s;
	} );
	sys.define_primitive( "SPACE", function ( s ) {
		s.output_text(" ");
		return s;
	} );
	sys.define_primitive( "SPACES", function ( s ) {
		s.output_text(_spaces(s.pop()));
		return s;
	} );
	sys.define_primitive( "TYPE", function ( s ) {
		let value := s.pop();
		if ( typeof value == "String" ) {
			s.output_text(value);
			return s;
		}
		let address := s.pop();
		let len := value;
		let i := 0;
		while ( i < len ) {
			s.output_text(chr(_fetch_at( s, address + i )));
			i++;
		}
		return s;
	} );

	sys.define_primitive( "!", function ( s ) {
		let address := s.pop();
		let value := s.pop();
		_store_at( s, address, value );
		return s;
	} );
	sys.define_primitive( "@", function ( s ) {
		return s.push(_fetch_at( s, s.pop() ));
	} );
	sys.define_primitive( "+!", function ( s ) {
		let address := s.pop();
		let value := s.pop();
		_store_at( s, address, _fetch_at( s, address ) + value );
		return s;
	} );
	sys.define_primitive( "C!", function ( s ) {
		let address := s.pop();
		let value := s.pop();
		_store_at( s, address, value );
		return s;
	} );
	sys.define_primitive( "C@", function ( s ) {
		return s.push(_fetch_at( s, s.pop() ));
	} );
	sys.define_primitive( "HERE", function ( s ) {
		return s.push(s.get_here());
	} );
	sys.define_primitive( "ALLOT", function ( s ) {
		let count := s.pop();
		let i := 0;
		while ( i < count ) {
			s.get_memory().push(0);
			s{here}++;
			i++;
		}
		return s;
	} );
	sys.define_primitive( ",", function ( s ) {
		_store_at( s, s.get_here(), s.pop() );
		s{here}++;
		return s;
	} );
	sys.define_primitive( "CELLS", function ( s ) { return s; } );
	sys.define_primitive( "CELL+", function ( s ) {
		return s.push(s.pop() + 1);
	} );
	sys.define_primitive( "CHARS", function ( s ) { return s; } );
	sys.define_primitive( "CHAR+", function ( s ) {
		return s.push(s.pop() + 1);
	} );

	sys.define_primitive( "DECIMAL", function ( s ) {
		_store_at( s, s.get_dictionary().get("__BASE_ADDR").get_value(), 10 );
		return s;
	} );
	sys.define_primitive( "HEX", function ( s ) {
		_store_at( s, s.get_dictionary().get("__BASE_ADDR").get_value(), 16 );
		return s;
	} );

	sys.define_primitive( "WORDS", function ( s ) {
		for ( let name in s.get_word_order() ) {
			if ( substr( name, 0, 2 ) ne "__" ) {
				s.output_text(name _ " ");
			}
		}
		return s;
	} );
	sys.define_primitive( "BYE", function ( s ) { return s; } );
}

function forth_system ( options? ) {
	let system := new ForthSystem(
		output_callback: _option( options, "output_callback", null ),
	);
	return system;
}

function forth ( String source, options? ) {
	let system := forth_system(options);
	system.evaluate(
		source,
		"" _ _option( options, "source_name", "<string>" ),
	);
	return system.output();
}