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

Go to the documentation of this file.

/******************************************************************************
* MODULE     : class_inspect.cpp
* DESCRIPTION: Routines for inspection of data
* COPYRIGHT  : (C) 2009  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>
namespace mmx {

/******************************************************************************
* Type information
******************************************************************************/

generic
mmx_type_table () {
  vector<generic> v= all_type_names ();
  table<generic,generic> t (as<generic> (false));
  for (nat i=0; i<N(v); i++) t[v[i]]= as<generic> (true);
  return as<generic> (t);
}

generic
mmx_type (const generic& g) {
  if (N(g) != 2) return wrong_nr_args (g);
  generic r= eval (g[1]);
  if (is<exception> (r)) return r;
  return type_name (type (r));
}

bool
mmx_is_type (const generic& g) {
  vector<generic> v= all_type_names ();
  for (nat i=0; i<N(v); i++)
    if (g == v[i]) return true;
  if (is_func (g, GEN_ALIAS_TYPE))
    return mmx_is_type (g[1]);
  if (is_func (g, GEN_TUPLE_TYPE))
    return mmx_is_type (g[1]);
  return false;
}

generic
mmx_type_name (const int& i) {
  nat id= (nat) i;
  return type_name (id);
}

/******************************************************************************
* Symbol information
******************************************************************************/

generic
mmx_symbol_table () {
  environment env= get_environment (current_ev);
  while (!is_nil (env->next)) env= env->next;
  list<string> sl= env -> strings_for_completion ();
  table<generic,generic> t (as<generic> (false));
  while (!is_nil (sl)) {
    generic v= car (sl);
    t[v]= as<generic> (true);
    sl= cdr (sl);
  }
  return as<generic> (t);
}

bool
mmx_is_defined (const generic& g) {
  environment env= get_environment (current_ev);
  return env->contains (g);
}

generic
mmx_definition (const generic& g) {
  environment env= get_environment (current_ev);
  ASSERT (env->contains (g), "symbol not defined");
  return env[g];
}

/******************************************************************************
* Function information
******************************************************************************/

generic
mmx_function_name (const routine& fun) {
  return fun->name;
}

generic
mmx_function_body (const routine& fun) {
  generic g= fun->function_body ();
  if (is_func (g, GEN_SQTUPLE)) {
    vector<generic> v;
    for (nat i=1; i<N(g); i++) v << g[i];
    return as<generic> (v);
  }
  else return as<generic> (vec (g));
}

generic
mmx_function_type (const routine& fun) {
  generic g= fun->function_type ();
  if (is_func (g, GEN_SQTUPLE)) {
    vector<generic> v;
    for (nat i=1; i<N(g); i++) v << g[i];
    return as<generic> (v);
  }
  else return as<generic> (vec (g));
}

generic
mmx_function_forms (const routine& fun) {
  vector<generic> r;
  vector<routine> v= fun->meanings ();
  if (N(v) == 0) r << as<generic> (fun);
  else for (nat i=0; i<N(v); i++) r << as<generic> (v[i]);
  return as<generic> (r);
}

/******************************************************************************
* Testing generic arithmetic
******************************************************************************/

generic mmx_conv (const generic& x, const generic& y) { return convert (x,y); }
generic mmx_neg (const generic& x) { return -x; }
generic mmx_sqr (const generic& x) { return square (x); }
generic mmx_inv (const generic& x) { return invert (x); }
generic mmx_add (const generic& x, const generic& y) { return x + y; }
generic mmx_sub (const generic& x, const generic& y) { return x - y; }
generic mmx_mul (const generic& x, const generic& y) { return x * y; }
generic mmx_div (const generic& x, const generic& y) { return x / y; }
generic mmx_add_int (const generic& x, const int& y) { return x + y; }
generic mmx_sub_int (const generic& x, const int& y) { return x - y; }
generic mmx_mul_int (const generic& x, const int& y) { return x * y; }
generic mmx_div_int (const generic& x, const int& y) { return x / y; }
generic mmx_int_add (const int& x, const generic& y) { return x + y; }
generic mmx_int_sub (const int& x, const generic& y) { return x - y; }
generic mmx_int_mul (const int& x, const generic& y) { return x * y; }
generic mmx_int_div (const int& x, const generic& y) { return x / y; }

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

void
glue_inspect () {
  define ("type_table", mmx_type_table);
  define_primitive ("type", mmx_type);
  define ("type?", mmx_is_type);
  define ("type_name", mmx_type_name);

  define ("symbol_table", mmx_symbol_table);
  define ("defined?", mmx_is_defined);
  define ("definition", mmx_definition);

  define ("function_name", mmx_function_body);
  define ("function_type", mmx_function_type);
  define ("function_body", mmx_function_body);
  define ("function_forms", mmx_function_forms);

  define ("conv", mmx_conv);
  define ("neg", mmx_neg);
  define ("sqr", mmx_sqr);
  define ("inv", mmx_inv);
  define ("add", mmx_add);
  define ("sub", mmx_sub);
  define ("mul", mmx_mul);
  define ("div", mmx_div);
  define ("add_int", mmx_add_int);
  define ("sub_int", mmx_sub_int);
  define ("mul_int", mmx_mul_int);
  define ("div_int", mmx_div_int);
  define ("int_add", mmx_int_add);
  define ("int_sub", mmx_int_sub);
  define ("int_mul", mmx_int_mul);
  define ("int_div", mmx_int_div);
}

} // namespace mmx