/Users/mourrain/Devel/mmx/basix/src/generic_object.cpp

Go to the documentation of this file.

/******************************************************************************
* MODULE     : generic_object.cpp
* DESCRIPTION: User-defined types
* COPYRIGHT  : (C) 2008  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.
******************************************************************************/

#ifndef __GENERIC_OBJECT_HPP
#define __GENERIC_OBJECT_HPP
#include <basix/glue.hpp>
namespace mmx {

nat define_user_type (const generic& name);
nat get_user_type (const generic& name);

/******************************************************************************
* Dynamic user-defined types
******************************************************************************/

class generic_object_rep: public generic_rep {
public:
  generic rep;
  nat id;

protected:
  nat get_type () const { return id; }
  bool same_type (const generic& g) const { return type_id (g) == id; }
  nat get_symbolic_type () const { return SYMBOLIC_UNSPECIFIED; }
  nat get_species_type () const { return SPECIES_DEFAULT; }
  nat get_length () const { return 0; }
  generic get_child (nat i) const { ERROR ("invalid child"); return 0; }
  nat get_hard_hash_value () const { return hard_hash (rep); }
  nat get_exact_hash_value () const { return exact_hash (rep); }
  nat get_hash_value () const { return hash (rep); }
  bool is_hard_eq (const generic& g) const {
    if (type (g) != id) return false;
    return hard_eq (rep, ((generic_object_rep*) inspect (g)) -> rep); }
  bool is_exact_eq (const generic& g) const {
    if (type (g) != id) return false;
    return exact_eq (rep, ((generic_object_rep*) inspect (g)) -> rep); }
  bool is_equal (const generic& g) const {
    if (type (g) != id) return false;
    return rep == ((generic_object_rep*) inspect (g)) -> rep; }
  generic duplicate_me () const {
    return as_object (duplicate (rep), id); }
  syntactic expression () const {
    if (is_alias_type (id))
      return flatten (get_alias (as<alias<generic> > (rep)));
    else {
      //return apply ("object", flatten (rep), flatten (type_name (id))); }
      generic r= current_ev->apply (GEN_FLATTEN, as_object (rep, id));
      return as<syntactic> (r); } }
  generic binary_type () const {
    ERROR ("binary type not implemented for user objects"); }
  generic binary_disassemble () const {
    ERROR ("binary disassemble not implemented for user objects"); }
  void binary_write (const port& p) const {
    ERROR ("binary write not implemented for user objects"); }
  generic make_abstract_vector () const {
    ERROR ("invalid abstraction"); }
  generic make_concrete_vector (const generic& v) const {
    ERROR ("invalid concretization"); }

public:
  generic_object_rep (const generic& rep2, nat id2):
    rep (rep2), id (id2) {}
};

static bool object_equal (const generic& x, const generic& y) {
  return x == y; }
static bool object_unequal (const generic& x, const generic& y) {
  return x != y; }
static syntactic object_flatten (const generic& x) {
  nat id= type (x);
  generic rep= as_generic (x, id);
  return apply ("object", flatten (rep), flatten (type_name (id))); }

static generic object_alias (const generic& x) {
  nat alias_id= scalar_to_alias (type (x));
  return as_object (as<generic> (new_alias<generic> (x)), alias_id); }
static generic object_get_alias (const generic& x) {
  nat alias_id= type (x);
  return get_alias (as<alias<generic> > (as_generic (x, alias_id))); }
static generic object_set_alias (const generic& x, const generic& y) {
  nat alias_id= type (x);
  return set_alias (as<alias<generic> > (as_generic (x, alias_id)), y); }
static generic object_specialize_alias (const alias<generic>& x) {
  nat alias_id= scalar_to_alias (type (get_alias (x)));
  return as_object (as<generic> (x), alias_id); }
static alias<generic> object_generalize_alias (const generic& x) {
  nat alias_id= type (x);
  return as<alias<generic> > (as_generic (x, alias_id)); }

/******************************************************************************
* Definition of user types
******************************************************************************/

nat
define_user_type (const generic& name) {
  nat id= new_type_id ();
  nat alias_id= new_alias_type_id (id);
  // nat tuple_id= new_tuple_type_id (id);
  define_type_sub (name, id);
  define_type_sub (gen (GEN_ALIAS_TYPE, name), alias_id);
  // define_type_sub (gen (GEN_TUPLE_TYPE, name), tuple_id);

  {
    vector<nat> sig= vec<nat> (alias_id, id);
    routine r = unary_routine (GEN_ALIAS, object_alias);
    routine r2= change_signature (r, sig);
    current_ev->overload (GEN_ALIAS, as<generic> (r2), PENALTY_INCLUSION);
  }

  {
    vector<nat> sig= vec<nat> (id, alias_id);
    routine r = unary_routine (GEN_UNALIAS, object_get_alias);
    routine r2= change_signature (r, sig);
    alias_getter (alias_id, r2);  
  }

  {
    vector<nat> sig= vec<nat> (id, alias_id, id);
    routine r = binary_routine (GEN_UNALIAS, object_set_alias);
    routine r2= change_signature (r, sig);
    alias_setter (alias_id, r2);  
  }

  {
    vector<nat> sig= vec<nat> (alias_id, type_id<alias<generic> > ());
    routine r = unary_routine (GEN_SPECIALIZE, object_specialize_alias);
    routine r2= change_signature (r, sig);
    alias_specializer (id, r2);
  }

  {
    vector<nat> sig= vec<nat> (id, alias_id);
    generic cv= gen (GEN_INTO, name, gen (GEN_ALIAS_TYPE, name));
    routine r = unary_routine (cv, object_get_alias);
    routine r2= change_signature (r, sig);
    current_ev->overload (GEN_REWRITE, as<generic> (r2), PENALTY_INCLUSION);
  }

  {
    vector<nat> sig= vec<nat> (type_id<alias<generic> > (), alias_id);
    generic cv= gen (GEN_INTO, gen (GEN_ALIAS_TYPE, GEN_GENERIC_TYPE),
                               gen (GEN_ALIAS_TYPE, name));
    routine r = unary_routine (cv, object_generalize_alias);
    routine r2= change_signature (r, sig);
    current_ev->overload (GEN_REWRITE, as<generic> (r2), PENALTY_INCLUSION);
  }

  {
    vector<nat> sig= vec<nat> (type_id<bool> (), id, id);
    routine r = binary_routine (GEN_EQUAL, object_equal);
    routine r2= change_signature (r, sig);
    current_ev->overload (GEN_EQUAL, as<generic> (r2), PENALTY_INCLUSION);
  }

  {
    vector<nat> sig= vec<nat> (type_id<bool> (), id, id);
    routine r = binary_routine (GEN_UNEQUAL, object_unequal);
    routine r2= change_signature (r, sig);
    current_ev->overload (GEN_UNEQUAL, as<generic> (r2), PENALTY_INCLUSION);
  }

  {
    vector<nat> sig= vec<nat> (type_id<syntactic> (), id);
    routine r = unary_routine (GEN_FLATTEN, object_flatten);
    routine r2= change_signature (r, sig);
    current_ev->overload (GEN_FLATTEN, as<generic> (r2), PENALTY_INCLUSION);
  }

  return id;
}

nat
get_user_type (const generic& name) {
  nat r= type_id (name);
  if (r == 1) {
    generic tp= name;
    if (is_func (tp, GEN_TUPLE_TYPE, 1)) tp= tp[1];
    if (is_func (tp, GEN_ALIAS_TYPE, 1)) tp= tp[1];
    if (is_func (tp, GEN_GENERIC_ALIAS_TYPE, 1)) tp= tp[1];
    define_user_type (tp);
    r= type_id (name);
  }
  return r;
}

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

generic
as_object (const generic& g, nat tp_id) {
  return new generic_object_rep (g, tp_id);
};

generic
as_object (const generic& g, const generic& tp) {
  return new generic_object_rep (g, get_user_type (tp));
};

generic
as_generic (const generic& g, nat tp_id) {
  ASSERT (type (g) == tp_id, "type mismatch");
  return ((generic_object_rep*) inspect (g)) -> rep;
};

generic
as_generic (const generic& g, const generic& tp) {
  ASSERT (type (g) == get_user_type (tp), "type mismatch");
  return ((generic_object_rep*) inspect (g)) -> rep;
};

} // namespace mmx
#endif // __GENERIC_OBJECT_HPP