/Users/magix/mmx/mmxlight/src/environment.cpp

Go to the documentation of this file.

/******************************************************************************
* MODULE     : environment.cpp
* DESCRIPTION: Environments for the base evaluator
* 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 <basix/literal.hpp>
#include <basix/routine.hpp>
#include <basix/alias.hpp>
#include <basix/glue.hpp>
#include <mmxlight/environment.hpp>
namespace mmx {

/******************************************************************************
* Environment access
******************************************************************************/

generic
environment_rep::name () const {
  vector<generic> vars (entries (bindings));
  if (is_nil (next)) return gen (GEN_GLOBAL, vars);
  else return gen (GEN_LOCAL, append (vars, vec<generic> (next->name ())));
}

bool
environment_rep::contains (const generic& var) const {
  if (bindings->contains (var)) return true;
  else if (is_nil (next)) return false;
  else if (next->contains (var)) {
    environment_rep* me= const_cast<environment_rep*> (this);
    me->bindings [var]= next[var];
    return true;
  }
  else return false;
}

bool
environment_rep::get (const generic& var, generic& val) const {
  if (bindings->get (var, val)) return true;
  else if (is_nil (next)) return false;
  else if (next->get (var, val)) {
    environment_rep* me= const_cast<environment_rep*> (this);
    me->bindings [var]= val;
    return true;
  }
  else return false;
}

generic
environment_rep::get (const generic& var) const {
  generic val;
  if (bindings->get (var, val)) return val;
  else if (is_nil (next)) return val;
  else if (next->get (var, val)) {
    environment_rep* me= const_cast<environment_rep*> (this);
    me->bindings [var]= val;
    return val;
  }
  else return val;
}

list<string>
environment_rep::strings_for_completion () const {
  list<string> vars;

  iterator<generic> tmp = entries (bindings);
  for ( ; busy (tmp); ++tmp)
    if (is<literal> (*tmp)) 
      vars = cons (literal_to_string (*tmp), vars);

  tmp = iterate (all_type_names ());
  for ( ; busy (tmp); ++tmp) {
    generic g= *tmp;
    while (is<compound> (g) && N(g)>0) g= g[0];
    if (is<literal> (g))
      vars = cons (literal_to_string (g), vars);
  }
  
  return vars;
}

void
environment_rep::verify_if_unknown_types () const {
  extern generic type_name (nat id);
  iterator<generic> tmp = entries (bindings);
  generic val;
  bool exists_unknown;
  for ( ; busy (tmp); ++tmp) 
    if (get (*tmp, val) && is<routine> (val)) {
      routine f= as<routine> (val);
      vector<routine> vf;
      if ((*f) -> is_overloaded ())
        vf = (*f) -> meanings ();
      else
        vf << f;
      for (nat k=0; k<N(vf); k++) {
        f = vf[k];
        vector<nat> ids= f->signature ();
        exists_unknown = false;
        for (nat i=0; i<N(ids); i++) {
          if ((ids[i] == 1) || (type_name (ids[i]) == GEN_UNSPECIFIED_TYPE))
            exists_unknown = true;
        }
        if (exists_unknown)
          mmout << "Warning: unresolved type encountered in "
                << *tmp << ": " << f << "\n";
      }
    }
}

/******************************************************************************
* Converters
******************************************************************************/

inline generic tag (const generic& name, nat id) {
  return gen (name, as<generic> (id)); }
inline generic tag (const generic& name, nat id1, nat id2) {
  return gen (name, as<generic> (id1), as<generic> (id2)); }

void
environment_rep::ensure_up_to_date () const {
  if (!is_nil (next)) {
    next->ensure_up_to_date ();
    if (next_serial != next->serial) {
      environment_rep* me= const_cast<environment_rep*> (this);
      me->serial++;
      me->next_serial= next->serial;
    }
  }
}

void
environment_rep::set_converter (nat src, nat dest, const generic& val,
                                nat trv, nat pen)
{
  /*
  mmout << "Set converter " << as_lisp (type_name (src));
  mmout << " -> " << as_lisp (type_name (dest));
  mmout << ", trv= " << trv;
  mmout << ", pen= " << pen;
  mmout << "\n";
  */

  // add the converter
  set (tag (GEN_CONVERTER, src, dest), val);
  set (tag (GEN_TRANSITIVE, src, dest), as<generic> (trv));
  set (tag (GEN_PENALTY, src, dest), as<generic> (pen));

  // add the converter to the list of converters
  generic t= tag (GEN_CONVERTERS, src);
  if (!contains (t)) set (t, as<generic> (vec<nat> ()));
  set (t, as<generic> (cons<nat> (dest, as<vector<nat> > (get (t)))));

  // time stamp
  environment_rep* me= const_cast<environment_rep*> (this);
  me->serial++;
}

generic
environment_rep::get_converter (nat src, nat dest, nat& pen) const {
  //mmout << "Convert: " << src << ", " << dest << "\n";
  if (src == dest) {
    pen= 0;
    return as<generic> (identity_routine (vec<nat> (dest, src)));
  }
  if (dest == 0) {
    if (is_alias_type (src)) {
      routine r;
      alias_getter (src, r);
      pen= PENALTY_FALL_BACK;
      return as<generic> (r);
    }
    else {
      pen= PENALTY_FALL_BACK;
      return as<generic> (identity_routine (vec<nat> (dest, src)));
    }
  }

  ensure_up_to_date ();
  generic stamp;
  bool ok= get (tag (GEN_CACHE_CONVERTERS, src), stamp);
  if (!ok || !is<nat> (stamp) || serial != as<nat> (stamp)) {
    environment_rep* me= const_cast<environment_rep*> (this);
    table<routine,nat> funt;
    table<nat,nat> trvt;
    table<nat,nat> pent;
    vector<nat> todo;

    // setup identity converter
    routine id= identity_routine (vec<nat> (src, src));
    me->set (tag (GEN_CACHE_CONVERTER, src, src), as<generic> (id));
    me->set (tag (GEN_CACHE_PENALTY, src, src), as<generic> ((nat) 0));
    funt [src]= id;
    trvt [src]= 3;
    pent [src]= 0;
    todo << src;

    // setup converter to generic
    if (src != 0) {
      if (is_alias_type (src)) {
        routine r;
        alias_getter (src, r);
        id= r;
      }
      else id= identity_routine (vec<nat> ((nat) 0, src));
      me->set (tag (GEN_CACHE_CONVERTER, src, (nat) 0), as<generic> (id));
      me->set (tag (GEN_CACHE_PENALTY, src, (nat) 0),
               as<generic> ((nat) PENALTY_FALL_BACK));
      funt [0]= id;
      trvt [0]= 3;
      pent [0]= PENALTY_FALL_BACK;
      todo << 0;
    }

    // transitive closure
    for (nat i=0; i<N(todo); i++) {
      nat cur= read (todo, i);
      generic cvs;
      if (get (tag (GEN_CONVERTERS, cur), cvs)) {
        generic all= gen (GEN_CONVERTERS, as<generic> (cur));
        vector<nat> succ= as<vector<nat> > (cvs);
        for (nat j=0; j<N(succ); j++) {
          nat     next    = read (succ, j);
          generic next_fun= get (tag (GEN_CONVERTER, cur, next));
          generic next_trv= get (tag (GEN_TRANSITIVE, cur, next));
          generic next_pen= get (tag (GEN_PENALTY, cur, next));
          ASSERT (is<routine> (next_fun), "routine expected (get_converter)");
          ASSERT (is<nat> (next_trv), "nat expected (get_converter)");
          ASSERT (is<nat> (next_pen), "nat expected (get_converter)");
          nat trv1= read (trvt, cur), trv2= as<nat> (next_trv);
          nat pen1= read (pent, cur), pen2= as<nat> (next_pen);
          nat trv= (trv1&1) + (trv2&2);
          nat pen= max (pen1, pen2);
          if (((trv1&2) != 0 ||
               (trv2&1) != 0) &&
              (!funt->contains (next) ||
               pen <= read (pent, next)) &&
              (pen < read (pent, next) ||
               (trv & (~read (trvt, next))) > 0))
            {
              routine fun=
                compose (as<routine> (next_fun), read (funt, cur));
              me->set (tag (GEN_CACHE_CONVERTER, src, next), as<generic>(fun));
              me->set (tag (GEN_CACHE_PENALTY, src, next), as<generic>(pen));
              funt [next]= fun;
              trvt [next]= trv;
              pent [next]= pen;
              todo << next;
              //mmout << "Converter " << type_name (src) << " -> "
              //      << type_name (next) << ": " << pen << "\n";
            }
        }
      }
    }

    // time stamp
    me->set (tag (GEN_CACHE_CONVERTERS, src), as<generic> (serial));
  }

  generic fun;
  if (get (tag (GEN_CACHE_CONVERTER, src, dest), fun)) {
    generic penalty;
    get (tag (GEN_CACHE_PENALTY, src, dest), penalty);
    VERIFY (is<nat> (penalty), "penalty not found");
    pen= as<nat> (penalty);
    return fun;
  }
  pen= PENALTY_INVALID;
  return as<generic> (routine ());
}

} // namespace mmx