text: /*=============================================================================
      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
  