/Users/magix/mmx/mmxlight/glue/glue_control.cpp

Go to the documentation of this file.

/******************************************************************************
* MODULE     : control_glue.cpp
* DESCRIPTION: Mathemagix control structures
* COPYRIGHT  : (C) 2006  Joris van der Hoeven
*******************************************************************************
* This software falls under the GNU general public license and comes WITHOUT
* ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for more details.
* If you don't have this file, write to the Free Software Foundation, Inc.,
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
******************************************************************************/

#include <mmxlight/mmxlight_glue.hpp>
#include <mmxlight/base_evaluator.hpp>
#include <basix/source_track.hpp>
namespace mmx {

/******************************************************************************
* Foreign declarations
******************************************************************************/

generic
mmx_foreign (const generic& x) {
  (void) x;
  return void_value ();
}

/******************************************************************************
* Begin statement
******************************************************************************/

generic
mmx_begin (const generic& x) {
  nat i, n= N(x);
  if (n==1) return void_value ();
  for (i=1; i<n-1; i++) {
    //mmout << "Evaluate " << x[i] << "\n";
    generic aux= eval (x[i]);
    if (is<exception> (aux)) return aux;
  }
  return eval (x[i]);
}

/******************************************************************************
* Boolean operations
******************************************************************************/

generic
mmx_seqand (const generic& x) {
  if (N(x) != 3) return wrong_nr_args (x);
  generic r= eval_as<bool> (x[1]);
  if (is<exception> (r) || !as<bool> (r)) return r;
  return eval_as<bool> (x[2]);
}

generic
mmx_seqor (const generic& x) {
  if (N(x) != 3) return wrong_nr_args (x);
  generic r= eval_as<bool> (x[1]);
  if (is<exception> (r) || as<bool> (r)) return r;
  return eval_as<bool> (x[2]);
}

bool
mmx_not (const bool& x) {
  return !x;
}

bool
mmx_xor (const bool& x1, const bool& x2) {
  return x1 ^ x2;
}

/******************************************************************************
* If statement
******************************************************************************/

generic
mmx_if (const generic& x) {
  if (N(x) < 3 || N(x) > 4) return wrong_nr_args (x);
  generic cond= eval_as<bool> (x[1]);
  if (is<exception> (cond)) return cond;
  if (as<bool> (cond)) return eval (x[2]);
  else if (N(x) == 4) return eval (x[3]);
  else return void_value ();
}

/******************************************************************************
* Loop statement
******************************************************************************/

generic
mmx_loop (const generic& x) {
  nat i, n= N(x)-1;
  if (n < 1) return wrong_nr_args (x);
  bool stop= false;
  generic aux, ret= void_value ();
  select_evaluator (base_evaluator (current_ev));

  table<iterator<generic>, generic> its;
  table<nat, generic> tps (0);
  for (i=1; i<n; i++)
    if (is_func (x[i], GEN_FOR, 1) && is_func (x[i][1], GEN_IN, 2)) {
      generic var= x[i][1][1];
      if (is_func (var, GEN_TYPE, 2)) {
        generic tp= eval (var[2]);
        if (is<exception> (tp)) { ret= tp; stop= true; break; }
        nat tid= type_id (tp);
        if (tid == 1) {
          ret= type_mismatch (GEN_TYPE_TYPE, var[2]); stop= true; break; }
        var= var[1];
        tps [var]= tid;
      }
      generic val= eval_as<iterator<generic> > (x[i][1][2]);
      if (is<exception> (val)) { ret= val; stop= true; break; }
      its [var]= as<iterator<generic> > (val);
    }
    else if (is_func (x[i], GEN_FOR, 1)) {
      aux= eval (x[i][1]);
      if (is<exception> (aux)) {
        stop= true;
        ret= aux;
        break;
      }
    }

  while (!stop) {
    for (i=1; i<n; i++)
      if (is_func (x[i], GEN_FOR, 1) && is_func (x[i][1], GEN_IN, 2)) {
        generic var= x[i][1][1];
        bool typed= is_func (var, GEN_TYPE, 2);
        if (typed) var= var[1];
        iterator<generic>& it= its [var];
        if (done (it)) { stop= true; break; }
        aux= *it; ++it;
        if (typed) aux= convert_to (aux, read (tps, var), x[i][1][2]);
        if (is<exception> (aux)) { ret= aux; stop= true; break; }
        current_ev->set (var, aux);
      }
      else if (is_func (x[i], GEN_WHILE, 1)) {
        generic cond= eval_as<bool> (x[i][1]);
        if (is<exception> (cond)) { ret= cond; stop= true; break; }
        if (!as<bool> (cond)) { stop= true; break; }
      }
    if (stop) break;

    select_evaluator (base_evaluator (current_ev));
    aux= eval (x[n]);
    restore_evaluator ();    

    if (is<exception> (aux)) {
      generic msg= *as<exception> (aux);
      if (exact_eq (msg, gen (GEN_CONTINUE)));
      else if (exact_eq (msg, gen (GEN_BREAK))) break;
      else { ret= aux; break; }
    }

    for (i=1; i<n; i++)
      if (is_func (x[i], GEN_UNTIL, 1)) {
        generic cond= eval_as<bool> (x[i][1]);
        if (is<exception> (cond)) { ret= cond; stop= true; break; }
        if (as<bool> (cond)) { stop= true; break; }
      }
      else if (is_func (x[i], GEN_STEP, 1)) {
        aux= eval (x[i][1]);
        if (is<exception> (aux)) { ret= aux; stop= true; break; }
      }
  }

  restore_evaluator ();
  return ret;
}

generic
mmx_break (const generic& x) {
  if (N(x) != 1) return wrong_nr_args (x);
  return as<generic> (exception (gen (GEN_BREAK)));
}

generic
mmx_continue (const generic& x) {
  if (N(x) != 1) return wrong_nr_args (x);
  return as<generic> (exception (gen (GEN_CONTINUE)));
}

/******************************************************************************
* Range generation
******************************************************************************/

class count_iterator_rep: public iterator_rep<generic> {
  int start, end;
public:
  count_iterator_rep (const int& s, const int& e): start (s), end (e) {}
  ~count_iterator_rep () {}
protected:
  bool is_busy () { return start < end; }
  void advance () { start++; }
  generic current () { return as<generic> (start); }
  iterator_rep<generic>* clone () {
    return new count_iterator_rep (start, end); }
};

static iterator<generic>
count_iterator (const int& start, const int& end) {
  return iterator<generic> (new count_iterator_rep (start, end));
}

generic
mmx_count (const int& end) {
  return as<generic> (count_iterator (0, end));
}

generic
mmx_range (const generic& start, const generic& end) {
  return as<generic> (range_iterator<generic> (start, end, 1, true));
}

generic
mmx_to (const generic& start, const generic& end) {
  return as<generic> (range_iterator<generic> (start, end, 1, false));
}

generic
mmx_downto (const generic& start, const generic& end) {
  return as<generic> (range_iterator<generic> (start, end, -1, false));
}

/******************************************************************************
* Where generators
******************************************************************************/

class extract_iterator_rep: public iterator_rep<generic> {
  evaluator ev;
  generic var;
  iterator<generic> it;
  generic cond;
  generic body;
  generic value;

  void spool () {
    select_evaluator (ev);
    while (busy (it)) {
      generic val= *it;
      current_ev->set (var, val);
      generic ok= eval_as<bool> (cond);
      if (is<exception> (ok)) {
        value= ok;
        break;
      }
      else if (as<bool> (ok)) {
        value= eval (body);
        break;
      }
      else ++it;
    }
    restore_evaluator ();
    if (done (it)) value= void_value ();
  }

public:
  extract_iterator_rep (const evaluator& e, const generic& v,
                        const iterator<generic>& i, const generic& c,
                        const generic& b):
      ev (e), var (v), it (i), cond (c), body (b) { spool (); }
  ~extract_iterator_rep () {
    /*
    mmout << "Destroy iterator on " << flush_now;
    mmout << as_lisp (var) << ": " << as_lisp (body);
    mmout << ", " << ev->ref_count;
    mmout << "\n";
    //mmout << "Destroy " << body << " where "
    //<< var << " in iterator satisfies " << cond << "\n";
    */
  }

protected:
  bool is_busy () { return busy (it); }
  void advance () { ++it; spool(); }
  generic current () { return value; }
  iterator_rep<generic>* clone () {
    extract_iterator_rep* rep=
      new extract_iterator_rep (ev, var, it, cond, body);
    rep->value= value;
    return rep;
  }
};


inline iterator<generic>
extract_iterator (const evaluator& ev, const generic& var,
                  const iterator<generic>& it, const generic& cond,
                  const generic& v)
{
  return iterator<generic> (new extract_iterator_rep (ev, var, it, cond, v));
}

class unnest_iterator_rep: public iterator_rep<generic> {
  iterator<generic> it;
  iterator<generic> subit;

  void spool () {
    while (busy (it)) {
      generic val= *it; ++it;
      if (!is<exception> (val) && !is<iterator<generic> > (val))
        val= type_mismatch (gen (GEN_GENERATOR_TYPE, GEN_GENERIC_TYPE), val);
      if (is<exception> (val)) subit= seq<generic> (val);
      else subit= as<iterator<generic> > (val);
      if (busy (subit)) break;
    }
  }

public:
  unnest_iterator_rep (const iterator<generic>& i):
    it (i) { spool (); }
  unnest_iterator_rep (const iterator<generic>& i, const iterator<generic>& j):
    it (i), subit (j) {}
  ~unnest_iterator_rep () {}

protected:
  bool is_busy () { return busy (subit); }
  void advance () { ++subit; if (done (subit)) spool(); }
  generic current () { return *subit; }
  iterator_rep<generic>* clone () {
    unnest_iterator_rep* rep= new unnest_iterator_rep (it, subit);
    return rep;
  }
};

inline iterator<generic>
unnest_iterator (const iterator<generic>& it) {
  return iterator<generic> (new unnest_iterator_rep (it));
}

generic
mmx_where (const generic& x) {
  nat i, n= N(x);
  if (n < 3) return wrong_nr_args (x);
  if (is_func (x[1], GEN_IN, 2)) {
    // TODO: generalize syntax when x[1] is a tuple
    // with elements of the form 'variable in generator'.
    return mmx_where (append (gen (x[0], x[1][1], x[1]), range (x, 2, N(x))));
  }
  if (!is_func (x[2], GEN_IN, 2))
    return std_exception ("'variable in generator' expected", x[2]);
  for (i=3; i<n; i++)
    if (is_func (x[i], GEN_IN, 2))
      break;
  if (i == n) {
    generic cond= GEN_TRUE;
    if (i > 3) {
      cond= x[i-1];
      for (nat j=i-2; j>=3; j--)
        cond= gen (GEN_SEQAND, x[j], cond);
    }
    generic body= x[1];
    generic var = x[2][1];
    if (is_func (var, GEN_TYPE, 2)) {
      // FIXME: should really declare variable of specified type
      var = var[1];
    }
    if (!is<literal> (var)) return type_mismatch (GEN_LITERAL_TYPE, var);
    generic val= eval_as<iterator<generic> > (x[2][2]);
    if (is<exception> (val)) return val;
    evaluator ev= base_evaluator (current_ev);
    iterator<generic> it= as<iterator<generic> > (val);
    iterator<generic> r = extract_iterator (ev, var, it, cond, body);
    generic ret= as<generic> (r);
    return ret;
  }
  else {
    generic inner= append (gen (x[0], x[1]), range (x, i, n));
    generic outer= append (gen (x[0], inner), range (x, 2, i));
    generic it= mmx_where (outer);
    if (is<exception> (it)) return it;
    return as<generic> (unnest_iterator (as<iterator<generic> > (it)));
  }
}

/******************************************************************************
* Grouping (tuples and generators)
******************************************************************************/

tuple<generic>
mmx_fill (const generic& x, const int& nr) {
  ASSERT (nr >= 0, "positive integer expected");
  return as_tuple (fill<generic> (x, nr));
}

tuple<generic>
mmx_tuple (const tuple<generic>& t) {
  return t;
}

iterator<generic>
mmx_explode (const iterator<generic>& it) {
  return it;
}

generic
mmx_protect (const generic& x) {
  if (N(x) != 2) return wrong_nr_args (x);
  generic it= eval (x[1]);
  if (is<exception> (it)) return it;
  else return gen ("protect", it);
}

generic
mmx_unprotect (const generic& x) {
  if (N(x) != 2) return wrong_nr_args (x);
  generic it= eval (x[1]);
  if (is<compound> (it) && N(it) == 2 && it[0] == "protect") return it[1];
  return std_exception ("protected generator expected", x[1]);
}

/******************************************************************************
* Error handling
******************************************************************************/

extern nat backtrace_depth;

class backtrace_depth_rep: public alias_rep<int> {
MMX_ALLOCATORS
  int prec;
public:
  inline backtrace_depth_rep () {}
  int get () const { return backtrace_depth; }
  int& open () const { return *((int*) ((void*) (&backtrace_depth))); }
  void close () const {}
};

class var_exception {
MMX_ALLOCATORS
  generic rep;
public:
  inline generic operator * () const { return rep; }
  inline var_exception (const generic& g): rep (g) {}
};

inline syntactic flatten (const var_exception& e) { return flatten (*e); }
WRAP_INDIRECT_IMPL(inline,var_exception)

var_exception
mmx_exception (const string& msg, const generic& where) {
  return var_exception (std_exception (msg, where));
}

string
mmx_exception_as_string (const var_exception& exc) {
  return source_exception (as<exception> (*exc));
}

generic
mmx_try (const generic& x) {
  if (N(x) < 2) return wrong_nr_args (x);

  generic body= x[1];
  if (!is_func (body, GEN_BEGIN)) body= gen (GEN_BEGIN, body);
  vector<generic> v= compound_to_vector (x);
  v= range (v, 2, N(v));
  v << cdr (compound_to_vector (body));
  body= gen (GEN_BEGIN, v);

  select_evaluator (base_evaluator (current_ev));
  generic r= eval (body);
  if (is<exception> (r)) {
    generic err= *as<exception> (r), ret;
    if (is<vector<generic> > (err[1]))
      ret= current_ev->apply (GEN_CATCH, as<vector<generic> > (err[1]));
    else ret= current_ev->apply (GEN_CATCH, as<generic> (var_exception (r)));
    if (!is_func (ret, GEN_CATCH)) r= ret;
  }
  restore_evaluator ();

  return r;
}

generic
mmx_raise (const generic& x) {
  vector<generic> args;
  for (nat i=1; i<N(x); i++) {
    generic r= eval (x[i]);
    if (is<exception> (r)) return r;
    else args << r;
  }
  if (N(args) == 1 && is<var_exception> (args[0]))
    return *as<var_exception> (args[0]);
  else return user_exception (args, x);
}

/******************************************************************************
* Interface
******************************************************************************/

void
glue_control () {
  static alias<int> depth= new backtrace_depth_rep ();
  define_constant<alias<int> > ("backtrace_depth", depth);
  define_type<var_exception> ("Exception");
  define_type<iterator<generic> > (gen("Generator",generic("Generic")));
  define_primitive (GEN_FOREIGN, mmx_foreign);
  define_primitive (GEN_BEGIN, mmx_begin);
  define_primitive (GEN_SEQAND, mmx_seqand);
  define_primitive (GEN_SEQOR, mmx_seqor);
  define           (GEN_NOT, mmx_not);
  define           (GEN_XOR, mmx_xor);
  define_primitive (GEN_IF, mmx_if);
  define_primitive (GEN_LOOP, mmx_loop);
  define_primitive (GEN_BREAK, mmx_break);
  define_primitive (GEN_CONTINUE, mmx_continue);
  define           (GEN_RANGE, mmx_range);
  define           ("count", mmx_count);
  define           (GEN_TO, mmx_to);
  define           (GEN_DOWNTO, mmx_downto);
  define_primitive (GEN_WHERE, mmx_where);
  define_primitive (GEN_VWHERE, mmx_where);
  define           (GEN_FILL, mmx_fill);
  define           (GEN_TUPLE, mmx_tuple);
  define           (GEN_EXPLODE, mmx_explode);
  define_primitive ("protect", mmx_protect);
  define_primitive ("unprotect", mmx_unprotect);
  define           ("exception", mmx_exception);
  define           ("as_string", mmx_exception_as_string);
  define_primitive (GEN_TRY, mmx_try);
  define_primitive (GEN_RAISE, mmx_raise);
}

} // namespace mmx