boost_1_45_0/libs/spirit/example/scheme/scheme/compiler.hpp - nest-learning-thermostat/5.0/boost - Git at Google

 /*=============================================================================
     Copyright (c) 2001-2010 Joel de Guzman

     Distributed under the Boost Software License, Version 1.0. (See accompanying
     file LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt)
 =============================================================================*/
 #if !defined(BOOST_SPIRIT_SCHEME_COMPILER)
 #define BOOST_SPIRIT_SCHEME_COMPILER

 #include <vector>
 #include <map>
 #include <exception>

 #include <boost/bind.hpp>
 #include <boost/tuple/tuple.hpp>
 #include <boost/lexical_cast.hpp>
 #include <scheme/intrinsics.hpp>
 #include <scheme/interpreter.hpp>
 #include <input/parse_sexpr.hpp>

 namespace scheme
 {
 ///////////////////////////////////////////////////////////////////////////////
 //  Exceptions
 ///////////////////////////////////////////////////////////////////////////////
     struct scheme_exception : std::exception {};

     struct compilation_error : std::exception
     {
         ~compilation_error() throw() {}
         virtual const char* what() const throw()
         {
             return "scheme: Compilation error.";
         }
     };

     struct identifier_expected : scheme_exception
     {
         ~identifier_expected() throw() {}
         virtual const char* what() const throw()
         {
             return "scheme: Identifier expected.";
         }
     };

     struct identifier_not_found : scheme_exception
     {
         std::string msg;
         identifier_not_found(std::string const& id)
           : msg("scheme: Identifier (" + id + ") not found.") {}
         ~identifier_not_found() throw() {}

         virtual const char* what() const throw()
         {
             return msg.c_str();;
         }
     };

     struct duplicate_identifier : scheme_exception
     {
         std::string msg;
         duplicate_identifier(std::string const& id)
           : msg("scheme: Duplicate identifier (" + id + ").") {}
         ~duplicate_identifier() throw() {}

         virtual const char* what() const throw()
         {
             return msg.c_str();
         }
     };

     struct body_already_defined : scheme_exception
     {
         std::string msg;
         body_already_defined(std::string const& id)
           : msg("scheme: Multiple definition (" + id + ").") {}
         ~body_already_defined() throw() {}

         virtual const char* what() const throw()
         {
             return msg.c_str();
         }
     };

     struct incorrect_arity : scheme_exception
     {
         std::string msg;
         incorrect_arity(std::string const& id, int arity, bool fixed)
           : msg("scheme: Invalid number of parameters to function call ("
                 + id + ").")
         {
             if (!fixed)
                 msg += std::string(" Expecting at least ");
             else
                 msg += std::string(" Expecting ");

             msg += boost::lexical_cast<std::string>(arity) + " arguments.";
         }
         ~incorrect_arity() throw() {}

         virtual const char* what() const throw()
         {
             return msg.c_str();
         }
     };

     struct function_application_expected : scheme_exception
     {
         std::string msg;
         function_application_expected(utree const& got)
         {
             // $$$ TODO: add got to message $$$
             msg = "scheme: Function application expected";
         }
         ~function_application_expected() throw() {}

         virtual const char* what() const throw()
         {
             return msg.c_str();
         }
     };

     struct no_body : scheme_exception
     {
         ~no_body() throw() {}
         virtual const char* what() const throw()
         {
             return "scheme: No expression in body.";
         }
     };

 ///////////////////////////////////////////////////////////////////////////////
 //  The environment
 ///////////////////////////////////////////////////////////////////////////////
     typedef boost::function<function(actor_list const&)> compiled_function;

     class environment
     {
     public:

         environment(environment* parent = 0)
           : outer(parent),
             depth(parent? parent->depth + 1 : 0)
         {}

         template <typename Function>
         void define(std::string const& name, Function const& f, int arity, bool fixed)
         {
             if (definitions.find(name) != definitions.end())
                 throw duplicate_identifier(name);
             definitions[name] = boost::make_tuple(compiled_function(f), arity, fixed);
         }

         boost::tuple<compiled_function*, int, bool>
         find(std::string const& name)
         {
             std::map<std::string, map_element>::iterator
                 i = definitions.find(name);
             if (i != definitions.end())
                 return boost::make_tuple(
                     &boost::get<0>(i->second),
                     boost::get<1>(i->second),
                     boost::get<2>(i->second)
                 );
             else if (outer != 0)
                 return outer->find(name);
             return boost::make_tuple((compiled_function*)0, 0, false);
         }

         void undefine(std::string const& name)
         {
             definitions.erase(name);
         }

         bool defined(std::string const& name)
         {
             return definitions.find(name) != definitions.end();
         }

         void forward_declare(std::string const& name, function* f)
         {
             forwards[name] = f;
         }

         function* find_forward(std::string const& name)
         {
             std::map<std::string, function*>::iterator
                 iter = forwards.find(name);
             if (iter == forwards.end())
                 return 0;
             else
                 return iter->second;
         }

         environment* parent() const { return outer; }
         int level() const { return depth; }

     private:

         typedef boost::tuple<compiled_function, int, bool> map_element;

         environment* outer;
         std::map<std::string, map_element> definitions;
         std::map<std::string, function*> forwards;
         int depth;
     };

 ///////////////////////////////////////////////////////////////////////////////
 //  The compiler
 ///////////////////////////////////////////////////////////////////////////////
     function compile(
         utree const& ast,
         environment& env,
         actor_list& fragments,
         int parent_line,
         std::string const& source_file = "");

     struct external_function : composite<external_function>
     {
         // we must hold f by reference because functions can be recursive
         boost::reference_wrapper<function const> f;
         int level;

         external_function(function const& f, int level)
           : f(f), level(level) {}

         using base_type::operator();
         function operator()(actor_list const& elements) const
         {
             return function(lambda_function(f, elements, level));
         }
     };

     struct compiler
     {
         typedef function result_type;
         environment& env;
         actor_list& fragments;
         int line;
         std::string source_file;

         compiler(
             environment& env,
             actor_list& fragments,
             int line,
             std::string const& source_file = "")
           : env(env), fragments(fragments),
             line(line), source_file(source_file)
         {
         }

         function operator()(nil) const
         {
             return scheme::val(utree());
         }

         template <typename T>
         function operator()(T const& val) const
         {
             return scheme::val(utree(val));
         }

         function operator()(utf8_symbol_range const& str) const
         {
             std::string name(str.begin(), str.end());
             boost::tuple<compiled_function*, int, bool> r = env.find(name);
             if (boost::get<0>(r))
             {
                 actor_list flist;
                 return (*boost::get<0>(r))(flist);
             }
             throw identifier_not_found(name);
             return function();
         }

         function make_lambda(
             std::vector<std::string> const& args,
             bool fixed_arity,
             utree const& body) const
         {
             environment local_env(&this->env);
             for (std::size_t i = 0; i < args.size(); ++i)
             {
                 if (!fixed_arity && (args.size() - 1) == i)
                     local_env.define(args[i],
                         boost::bind(varg, i, local_env.level()), 0, false);
                 else
                     local_env.define(args[i],
                         boost::bind(arg, i, local_env.level()), 0, false);
             }

             actor_list flist;
             if (body.size() == 0)
                 return function();
                 //~ throw no_body();

             BOOST_FOREACH(utree const& item, body)
             {
                 function f = compile(item, local_env, fragments, line, source_file);
                 if (!is_define(item))
                     flist.push_back(f);
             }
             if (flist.size() > 1)
                 return protect(block(flist));
             else
                 return protect(flist.front());
         }

         static bool is_define(utree const& item)
         {
             if (item.which() != utree_type::list_type ||
                 item.begin()->which() != utree_type::symbol_type)
                 return false;
             return get_symbol(*item.begin()) == "define";
         }

         function define_function(
             std::string const& name,
             std::vector<std::string>& args,
             bool fixed_arity,
             utree const& body) const
         {
             try
             {
                 function* fp = 0;
                 if (env.defined(name))
                 {
                     fp = env.find_forward(name);
                     if (fp != 0 && !fp->empty())
                         throw body_already_defined(name);
                 }

                 if (fp == 0)
                 {
                     fragments.push_back(function());
                     fp = &fragments.back();
                     env.define(name, external_function(*fp, env.level()), args.size(), fixed_arity);
                 }

                 function lambda = make_lambda(args, fixed_arity, body);
                 if (!lambda.empty())
                 {
                     // unprotect (eval returns a function)
                     *fp = lambda();
                 }
                 else
                 {
                     // allow forward declaration of scheme functions
                     env.forward_declare(name, fp);
                 }
                 return *fp;
             }
             catch (std::exception const&)
             {
                 env.undefine(name);
                 throw;
             }
         }

         function operator()(utree::const_range const& range) const
         {
             typedef utree::const_range::iterator iterator;

             if (range.begin()->which() != utree_type::symbol_type)
                 throw function_application_expected(*range.begin());

             std::string name(get_symbol(*range.begin()));

             if (name == "quote")
             {
                 iterator i = range.begin(); ++i;
                 return scheme::val(*i);
             }

             if (name == "define")
             {
                 std::string fname;
                 std::vector<std::string> args;
                 bool fixed_arity = true;

                 iterator i = range.begin(); ++i;
                 if (i->which() == utree_type::list_type)
                 {
                     // (define (f x) ...body...)
                     utree const& decl = *i++;
                     iterator di = decl.begin();
                     fname = get_symbol(*di++);
                     while (di != decl.end())
                     {
                         std::string sym = get_symbol(*di++);
                         if (sym == ".")
                            // check that . is one pos behind the last arg
                            fixed_arity = false;
                         else
                             args.push_back(sym);
                     }
                 }
                 else
                 {
                     // (define f ...body...)
                     fname = get_symbol(*i++);

                     // (define f (lambda (x) ...body...))
                     if (i != range.end()
                         && i->which() == utree_type::list_type
                         && get_symbol((*i)[0]) == "lambda")
                     {
                         utree const& arg_names = (*i)[1];
                         iterator ai = arg_names.begin();
                         while (ai != arg_names.end())
                         {
                             std::string sym = get_symbol(*ai++);
                             if (sym == ".")
                                 // check that . is one pos behind the last arg
                                 fixed_arity = false;
                             else
                                 args.push_back(sym);
                         };

                         iterator bi = i->begin(); ++bi; ++bi; // (*i)[2]
                         utree body(utree::const_range(bi, i->end()), shallow);
                         return define_function(fname, args, fixed_arity, body);
                     }
                 }

                 utree body(utree::const_range(i, range.end()), shallow);
                 return define_function(fname, args, fixed_arity, body);
             }

             if (name == "lambda")
             {
                 // (lambda (x) ...body...)
                 iterator i = range.begin(); ++i;
                 utree const& arg_names = *i++;
                 iterator ai = arg_names.begin();
                 std::vector<std::string> args;
                 bool fixed_arity = true;

                 while (ai != arg_names.end())
                 {
                     std::string sym = get_symbol(*ai++);
                     if (sym == ".")
                         // check that . is one pos behind the last arg
                         fixed_arity = false;
                     else
                         args.push_back(sym);
                 }

                 utree body(utree::const_range(i, range.end()), shallow);
                 return make_lambda(args, fixed_arity, body);
             }

             // (f x)
             boost::tuple<compiled_function*, int, bool> r = env.find(name);
             if (boost::get<0>(r))
             {
                 compiled_function* cf = boost::get<0>(r);
                 int arity = boost::get<1>(r);
                 bool fixed_arity = boost::get<2>(r);

                 actor_list flist;
                 iterator i = range.begin(); ++i;
                 int size = 0;
                 for (; i != range.end(); ++i, ++size)
                 {
                     flist.push_back(
                         compile(*i, env, fragments, line, source_file));
                 }

                 // Arity check
                 if (!fixed_arity) // non-fixed arity
                 {
                     if (size < arity)
                         throw incorrect_arity(name, arity, false);
                 }
                 else // fixed arity
                 {
                     if (size != arity)
                         throw incorrect_arity(name, arity, true);
                 }
                 return (*cf)(flist);
             }
             else
             {
                 throw identifier_not_found(name);
             }

             // Can't reach here
             throw compilation_error();
             return function();
         }

         function operator()(function_base const& pf) const
         {
             // Can't reach here. Surely, at this point, we don't have
             // utree functions yet. The utree AST should be pure data.
             throw compilation_error();
             return function();
         }

         static std::string get_symbol(utree const& s)
         {
             if (s.which() != utree_type::symbol_type)
                 throw identifier_expected();
             utf8_symbol_range symbol = s.get<utf8_symbol_range>();
             return std::string(symbol.begin(), symbol.end());
         }
     };

     inline function compile(
         utree const& ast,
         environment& env,
         actor_list& fragments,
         int parent_line,
         std::string const& source_file)
     {
         int line = (ast.which() == utree_type::list_type)
             ? ast.tag() : parent_line;

         try
         {
             return utree::visit(ast,
                 compiler(env, fragments, line, source_file));
         }
         catch (scheme_exception const& x)
         {
             if (source_file != "")
                 std::cerr << source_file;

             if (line != -1)
                 std::cerr << '(' << line << ')';

             std::cerr << " : Error! "  << x.what() << std::endl;
             throw compilation_error();
         }

         return function();
     }

     void compile_all(
         utree const& ast,
         environment& env,
         actor_list& results,
         actor_list& fragments,
         std::string const& source_file = "")
     {
         int line = (ast.which() == utree_type::list_type)
             ? ast.tag() : 1;
         BOOST_FOREACH(utree const& program, ast)
         {
             scheme::function f;
             try
             {
                 if (!compiler::is_define(program))
                 {
                     if (source_file != "")
                         std::cerr << source_file;

                     int progline = (program.which() == utree_type::list_type)
                         ? program.tag() : line;

                     if (progline != -1)
                         std::cerr << '(' << progline << ')';

                     std::cerr << " : Error! scheme: Function definition expected." << std::endl;
                     continue; // try the next expression
                 }
                 else
                 {
                     f = compile(program, env, fragments, line, source_file);
                 }
             }
             catch (compilation_error const&)
             {
                 continue; // try the next expression
             }
             results.push_back(f);
         }
     }

     void build_basic_environment(environment& env)
     {
         env.define("if", if_, 3, true);
         env.define("begin", block, 1, false);
         env.define("list", list, 1, false);
         env.define("display", display, 1, true);
         env.define("front", front, 1, true);
         env.define("back", back, 1, true);
         env.define("rest", rest, 1, true);
         env.define("=", equal, 2, true);
         env.define("<", less_than, 2, true);
         env.define("<=", less_than_equal, 2, true);
         env.define("+", plus, 2, false);
         env.define("-", minus, 2, false);
         env.define("*", times, 2, false);
         env.define("/", divide, 2, false);
     }

     ///////////////////////////////////////////////////////////////////////////
     // interpreter
     ///////////////////////////////////////////////////////////////////////////
     struct interpreter
     {
         template <typename Source>
         interpreter(
             Source& in,
             std::string const& source_file = "",
             environment* envp = 0)
         {
             if (envp == 0)
                 build_basic_environment(env);
             else
                 env = *envp;

             if (input::parse_sexpr_list(in, program, source_file))
             {
                 compile_all(program, env, flist, fragments, source_file);
             }
         }

         interpreter(
             utree const& program,
             environment* envp = 0)
         {
             if (envp == 0)
                 build_basic_environment(env);
             else
                 env = *envp;

             compile_all(program, env, flist, fragments);
         }

         function operator[](std::string const& name)
         {
             boost::tuple<compiled_function*, int, bool> r = env.find(name);
             if (boost::get<0>(r))
             {
                 compiled_function* cf = boost::get<0>(r);
                 int arity = boost::get<1>(r);
                 bool fixed_arity = boost::get<2>(r);
                 actor_list flist;

                 if (arity > 0)
                 {
                     for (int i = 0; i < (arity-1); ++i)
                         flist.push_back(arg(i));

                     if (fixed_arity)
                         flist.push_back(arg(arity-1));
                     else
                         flist.push_back(varg(arity-1));
                 }
                 return (*cf)(flist);
             }
             else
             {
                 std::cerr
                     << " : Error! scheme: Function "
                     << name
                     << " not found."
                     << std::endl;
                 return function();
             }
         }

         environment env;
         utree program;
         actor_list fragments;
         actor_list flist;
     };
 }

 #endif
	/*=============================================================================
	Copyright (c) 2001-2010 Joel de Guzman

	Distributed under the Boost Software License, Version 1.0. (See accompanying
	file LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt)
	=============================================================================*/
	#if !defined(BOOST_SPIRIT_SCHEME_COMPILER)
	#define BOOST_SPIRIT_SCHEME_COMPILER

	#include <vector>
	#include <map>
	#include <exception>

	#include <boost/bind.hpp>
	#include <boost/tuple/tuple.hpp>
	#include <boost/lexical_cast.hpp>
	#include <scheme/intrinsics.hpp>
	#include <scheme/interpreter.hpp>
	#include <input/parse_sexpr.hpp>

	namespace scheme
	{
	///////////////////////////////////////////////////////////////////////////////
	// Exceptions
	///////////////////////////////////////////////////////////////////////////////
	struct scheme_exception : std::exception {};

	struct compilation_error : std::exception
	{
	~compilation_error() throw() {}
	virtual const char* what() const throw()
	{
	return "scheme: Compilation error.";
	}
	};

	struct identifier_expected : scheme_exception
	{
	~identifier_expected() throw() {}
	virtual const char* what() const throw()
	{
	return "scheme: Identifier expected.";
	}
	};

	struct identifier_not_found : scheme_exception
	{
	std::string msg;
	identifier_not_found(std::string const& id)
	: msg("scheme: Identifier (" + id + ") not found.") {}
	~identifier_not_found() throw() {}

	virtual const char* what() const throw()
	{
	return msg.c_str();;
	}
	};

	struct duplicate_identifier : scheme_exception
	{
	std::string msg;
	duplicate_identifier(std::string const& id)
	: msg("scheme: Duplicate identifier (" + id + ").") {}
	~duplicate_identifier() throw() {}

	virtual const char* what() const throw()
	{
	return msg.c_str();
	}
	};

	struct body_already_defined : scheme_exception
	{
	std::string msg;
	body_already_defined(std::string const& id)
	: msg("scheme: Multiple definition (" + id + ").") {}
	~body_already_defined() throw() {}

	virtual const char* what() const throw()
	{
	return msg.c_str();
	}
	};

	struct incorrect_arity : scheme_exception
	{
	std::string msg;
	incorrect_arity(std::string const& id, int arity, bool fixed)
	: msg("scheme: Invalid number of parameters to function call ("
	+ id + ").")
	{
	if (!fixed)
	msg += std::string(" Expecting at least ");
	else
	msg += std::string(" Expecting ");

	msg += boost::lexical_cast<std::string>(arity) + " arguments.";
	}
	~incorrect_arity() throw() {}

	virtual const char* what() const throw()
	{
	return msg.c_str();
	}
	};

	struct function_application_expected : scheme_exception
	{
	std::string msg;
	function_application_expected(utree const& got)
	{
	// $$$ TODO: add got to message $$$
	msg = "scheme: Function application expected";
	}
	~function_application_expected() throw() {}

	virtual const char* what() const throw()
	{
	return msg.c_str();
	}
	};

	struct no_body : scheme_exception
	{
	~no_body() throw() {}
	virtual const char* what() const throw()
	{
	return "scheme: No expression in body.";
	}
	};

	///////////////////////////////////////////////////////////////////////////////
	// The environment
	///////////////////////////////////////////////////////////////////////////////
	typedef boost::function<function(actor_list const&)> compiled_function;

	class environment
	{
	public:

	environment(environment* parent = 0)
	: outer(parent),
	depth(parent? parent->depth + 1 : 0)
	{}

	template <typename Function>
	void define(std::string const& name, Function const& f, int arity, bool fixed)
	{
	if (definitions.find(name) != definitions.end())
	throw duplicate_identifier(name);
	definitions[name] = boost::make_tuple(compiled_function(f), arity, fixed);
	}

	boost::tuple<compiled_function*, int, bool>
	find(std::string const& name)
	{
	std::map<std::string, map_element>::iterator
	i = definitions.find(name);
	if (i != definitions.end())
	return boost::make_tuple(
	&boost::get<0>(i->second),
	boost::get<1>(i->second),
	boost::get<2>(i->second)
	);
	else if (outer != 0)
	return outer->find(name);
	return boost::make_tuple((compiled_function*)0, 0, false);
	}

	void undefine(std::string const& name)
	{
	definitions.erase(name);
	}

	bool defined(std::string const& name)
	{
	return definitions.find(name) != definitions.end();
	}

	void forward_declare(std::string const& name, function* f)
	{
	forwards[name] = f;
	}

	function* find_forward(std::string const& name)
	{
	std::map<std::string, function*>::iterator
	iter = forwards.find(name);
	if (iter == forwards.end())
	return 0;
	else
	return iter->second;
	}

	environment* parent() const { return outer; }
	int level() const { return depth; }

	private:

	typedef boost::tuple<compiled_function, int, bool> map_element;

	environment* outer;
	std::map<std::string, map_element> definitions;
	std::map<std::string, function*> forwards;
	int depth;
	};

	///////////////////////////////////////////////////////////////////////////////
	// The compiler
	///////////////////////////////////////////////////////////////////////////////
	function compile(
	utree const& ast,
	environment& env,
	actor_list& fragments,
	int parent_line,
	std::string const& source_file = "");

	struct external_function : composite<external_function>
	{
	// we must hold f by reference because functions can be recursive
	boost::reference_wrapper<function const> f;
	int level;

	external_function(function const& f, int level)
	: f(f), level(level) {}

	using base_type::operator();
	function operator()(actor_list const& elements) const
	{
	return function(lambda_function(f, elements, level));
	}
	};

	struct compiler
	{
	typedef function result_type;
	environment& env;
	actor_list& fragments;
	int line;
	std::string source_file;

	compiler(
	environment& env,
	actor_list& fragments,
	int line,
	std::string const& source_file = "")
	: env(env), fragments(fragments),
	line(line), source_file(source_file)
	{
	}

	function operator()(nil) const
	{
	return scheme::val(utree());
	}

	template <typename T>
	function operator()(T const& val) const
	{
	return scheme::val(utree(val));
	}

	function operator()(utf8_symbol_range const& str) const
	{
	std::string name(str.begin(), str.end());
	boost::tuple<compiled_function*, int, bool> r = env.find(name);
	if (boost::get<0>(r))
	{
	actor_list flist;
	return (*boost::get<0>(r))(flist);
	}
	throw identifier_not_found(name);
	return function();
	}

	function make_lambda(
	std::vector<std::string> const& args,
	bool fixed_arity,
	utree const& body) const
	{
	environment local_env(&this->env);
	for (std::size_t i = 0; i < args.size(); ++i)
	{
	if (!fixed_arity && (args.size() - 1) == i)
	local_env.define(args[i],
	boost::bind(varg, i, local_env.level()), 0, false);
	else
	local_env.define(args[i],
	boost::bind(arg, i, local_env.level()), 0, false);
	}

	actor_list flist;
	if (body.size() == 0)
	return function();
	//~ throw no_body();

	BOOST_FOREACH(utree const& item, body)
	{
	function f = compile(item, local_env, fragments, line, source_file);
	if (!is_define(item))
	flist.push_back(f);
	}
	if (flist.size() > 1)
	return protect(block(flist));
	else
	return protect(flist.front());
	}

	static bool is_define(utree const& item)
	{
	if (item.which() != utree_type::list_type \|\|
	item.begin()->which() != utree_type::symbol_type)
	return false;
	return get_symbol(*item.begin()) == "define";
	}

	function define_function(
	std::string const& name,
	std::vector<std::string>& args,
	bool fixed_arity,
	utree const& body) const
	{
	try
	{
	function* fp = 0;
	if (env.defined(name))
	{
	fp = env.find_forward(name);
	if (fp != 0 && !fp->empty())
	throw body_already_defined(name);
	}

	if (fp == 0)
	{
	fragments.push_back(function());
	fp = &fragments.back();
	env.define(name, external_function(*fp, env.level()), args.size(), fixed_arity);
	}

	function lambda = make_lambda(args, fixed_arity, body);
	if (!lambda.empty())
	{
	// unprotect (eval returns a function)
	*fp = lambda();
	}
	else
	{
	// allow forward declaration of scheme functions
	env.forward_declare(name, fp);
	}
	return *fp;
	}
	catch (std::exception const&)
	{
	env.undefine(name);
	throw;
	}
	}

	function operator()(utree::const_range const& range) const
	{
	typedef utree::const_range::iterator iterator;

	if (range.begin()->which() != utree_type::symbol_type)
	throw function_application_expected(*range.begin());

	std::string name(get_symbol(*range.begin()));

	if (name == "quote")
	{
	iterator i = range.begin(); ++i;
	return scheme::val(*i);
	}

	if (name == "define")
	{
	std::string fname;
	std::vector<std::string> args;
	bool fixed_arity = true;

	iterator i = range.begin(); ++i;
	if (i->which() == utree_type::list_type)
	{
	// (define (f x) ...body...)
	utree const& decl = *i++;
	iterator di = decl.begin();
	fname = get_symbol(*di++);
	while (di != decl.end())
	{
	std::string sym = get_symbol(*di++);
	if (sym == ".")
	// check that . is one pos behind the last arg
	fixed_arity = false;
	else
	args.push_back(sym);
	}
	}
	else
	{
	// (define f ...body...)
	fname = get_symbol(*i++);

	// (define f (lambda (x) ...body...))
	if (i != range.end()
	&& i->which() == utree_type::list_type
	&& get_symbol((*i)[0]) == "lambda")
	{
	utree const& arg_names = (*i)[1];
	iterator ai = arg_names.begin();
	while (ai != arg_names.end())
	{
	std::string sym = get_symbol(*ai++);
	if (sym == ".")
	// check that . is one pos behind the last arg
	fixed_arity = false;
	else
	args.push_back(sym);
	};

	iterator bi = i->begin(); ++bi; ++bi; // (*i)[2]
	utree body(utree::const_range(bi, i->end()), shallow);
	return define_function(fname, args, fixed_arity, body);
	}
	}

	utree body(utree::const_range(i, range.end()), shallow);
	return define_function(fname, args, fixed_arity, body);
	}

	if (name == "lambda")
	{
	// (lambda (x) ...body...)
	iterator i = range.begin(); ++i;
	utree const& arg_names = *i++;
	iterator ai = arg_names.begin();
	std::vector<std::string> args;
	bool fixed_arity = true;

	while (ai != arg_names.end())
	{
	std::string sym = get_symbol(*ai++);
	if (sym == ".")
	// check that . is one pos behind the last arg
	fixed_arity = false;
	else
	args.push_back(sym);
	}

	utree body(utree::const_range(i, range.end()), shallow);
	return make_lambda(args, fixed_arity, body);
	}

	// (f x)
	boost::tuple<compiled_function*, int, bool> r = env.find(name);
	if (boost::get<0>(r))
	{
	compiled_function* cf = boost::get<0>(r);
	int arity = boost::get<1>(r);
	bool fixed_arity = boost::get<2>(r);

	actor_list flist;
	iterator i = range.begin(); ++i;
	int size = 0;
	for (; i != range.end(); ++i, ++size)
	{
	flist.push_back(
	compile(*i, env, fragments, line, source_file));
	}

	// Arity check
	if (!fixed_arity) // non-fixed arity
	{
	if (size < arity)
	throw incorrect_arity(name, arity, false);
	}
	else // fixed arity
	{
	if (size != arity)
	throw incorrect_arity(name, arity, true);
	}
	return (*cf)(flist);
	}
	else
	{
	throw identifier_not_found(name);
	}

	// Can't reach here
	throw compilation_error();
	return function();
	}

	function operator()(function_base const& pf) const
	{
	// Can't reach here. Surely, at this point, we don't have
	// utree functions yet. The utree AST should be pure data.
	throw compilation_error();
	return function();
	}

	static std::string get_symbol(utree const& s)
	{
	if (s.which() != utree_type::symbol_type)
	throw identifier_expected();
	utf8_symbol_range symbol = s.get<utf8_symbol_range>();
	return std::string(symbol.begin(), symbol.end());
	}
	};

	inline function compile(
	utree const& ast,
	environment& env,
	actor_list& fragments,
	int parent_line,
	std::string const& source_file)
	{
	int line = (ast.which() == utree_type::list_type)
	? ast.tag() : parent_line;

	try
	{
	return utree::visit(ast,
	compiler(env, fragments, line, source_file));
	}
	catch (scheme_exception const& x)
	{
	if (source_file != "")
	std::cerr << source_file;

	if (line != -1)
	std::cerr << '(' << line << ')';

	std::cerr << " : Error! " << x.what() << std::endl;
	throw compilation_error();
	}

	return function();
	}

	void compile_all(
	utree const& ast,
	environment& env,
	actor_list& results,
	actor_list& fragments,
	std::string const& source_file = "")
	{
	int line = (ast.which() == utree_type::list_type)
	? ast.tag() : 1;
	BOOST_FOREACH(utree const& program, ast)
	{
	scheme::function f;
	try
	{
	if (!compiler::is_define(program))
	{
	if (source_file != "")
	std::cerr << source_file;

	int progline = (program.which() == utree_type::list_type)
	? program.tag() : line;

	if (progline != -1)
	std::cerr << '(' << progline << ')';

	std::cerr << " : Error! scheme: Function definition expected." << std::endl;
	continue; // try the next expression
	}
	else
	{
	f = compile(program, env, fragments, line, source_file);
	}
	}
	catch (compilation_error const&)
	{
	continue; // try the next expression
	}
	results.push_back(f);
	}
	}

	void build_basic_environment(environment& env)
	{
	env.define("if", if_, 3, true);
	env.define("begin", block, 1, false);
	env.define("list", list, 1, false);
	env.define("display", display, 1, true);
	env.define("front", front, 1, true);
	env.define("back", back, 1, true);
	env.define("rest", rest, 1, true);
	env.define("=", equal, 2, true);
	env.define("<", less_than, 2, true);
	env.define("<=", less_than_equal, 2, true);
	env.define("+", plus, 2, false);
	env.define("-", minus, 2, false);
	env.define("*", times, 2, false);
	env.define("/", divide, 2, false);
	}

	///////////////////////////////////////////////////////////////////////////
	// interpreter
	///////////////////////////////////////////////////////////////////////////
	struct interpreter
	{
	template <typename Source>
	interpreter(
	Source& in,
	std::string const& source_file = "",
	environment* envp = 0)
	{
	if (envp == 0)
	build_basic_environment(env);
	else
	env = *envp;

	if (input::parse_sexpr_list(in, program, source_file))
	{
	compile_all(program, env, flist, fragments, source_file);
	}
	}

	interpreter(
	utree const& program,
	environment* envp = 0)
	{
	if (envp == 0)
	build_basic_environment(env);
	else
	env = *envp;

	compile_all(program, env, flist, fragments);
	}

	function operator[](std::string const& name)
	{
	boost::tuple<compiled_function*, int, bool> r = env.find(name);
	if (boost::get<0>(r))
	{
	compiled_function* cf = boost::get<0>(r);
	int arity = boost::get<1>(r);
	bool fixed_arity = boost::get<2>(r);
	actor_list flist;

	if (arity > 0)
	{
	for (int i = 0; i < (arity-1); ++i)
	flist.push_back(arg(i));

	if (fixed_arity)
	flist.push_back(arg(arity-1));
	else
	flist.push_back(varg(arity-1));
	}
	return (*cf)(flist);
	}
	else
	{
	std::cerr
	<< " : Error! scheme: Function "
	<< name
	<< " not found."
	<< std::endl;
	return function();
	}
	}

	environment env;
	utree program;
	actor_list fragments;
	actor_list flist;
	};
	}

	#endif