Back to index

plt-scheme  4.2.1
Classes | Defines | Typedefs | Functions | Variables
tree.cxx File Reference
#include "escheme.h"

Go to the source code of this file.

Classes

class  Tree
class  mzTree
struct  Objscheme_Class

Defines

#define OBJSCHEME_GET_CPP_OBJ(obj)   scheme_struct_ref(obj, 0)
#define OBJSCHEME_SET_CPP_OBJ(obj, v)   scheme_struct_set(obj, 0, v)
#define CONS(a, b)   scheme_make_pair(a, b)

Typedefs

typedef struct Objscheme_Class Objscheme_Class

Functions

void objscheme_init ()
void objscheme_add_procedures (Scheme_Env *)
Scheme_Objectobjscheme_make_class (const char *name, Scheme_Object *sup, Scheme_Prim *initf, int num_methods)
Scheme_Objectobjscheme_add_method_w_arity (Scheme_Object *c, const char *name, Scheme_Prim *f, int mina, int maxa)
Scheme_Objectobjscheme_make_uninited_object (Scheme_Object *sclass)
Scheme_Objectobjscheme_find_method (Scheme_Object *obj, char *name, void **cache)
int objscheme_is_a (Scheme_Object *o, Scheme_Object *c)
void FreeTree (void *scmobj, void *t)
Scheme_ObjectMake_Tree (int argc, Scheme_Object **argv)
Scheme_ObjectGrow (int argc, Scheme_Object **argv)
Scheme_ObjectGraft (int argc, Scheme_Object **argv)
Scheme_ObjectMarshalTree (Tree *t)
Scheme_ObjectGet_Left (int argc, Scheme_Object **argv)
Scheme_ObjectGet_Right (int argc, Scheme_Object **argv)
Scheme_ObjectGet_Leaves (int argc, Scheme_Object **argv)
Scheme_Objectscheme_reload (Scheme_Env *env)
Scheme_Objectscheme_initialize (Scheme_Env *env)
Scheme_Objectscheme_module_name ()
static Scheme_Objectinit_prim_obj (int argc, Scheme_Object **argv)
static Scheme_Objectclass_prepare_struct_type (int argc, Scheme_Object **argv)
static Scheme_Objectclass_find_meth (int argc, Scheme_Object **argv)

Variables

static Scheme_Objecttree_class
static voidgrow_method_cache = NULL
Scheme_Objectgrow_prim
Scheme_Type objscheme_class_type
static Scheme_Objectobject_struct
static Scheme_Objectobject_property
static Scheme_Objectpreparer_property
static Scheme_Objectdispatcher_property

Class Documentation

struct Objscheme_Class

Definition at line 585 of file tree.cxx.

Collaboration diagram for Objscheme_Class:
Class Members
Scheme_Object * base_struct_type
Scheme_Object * initf
Scheme_Object ** methods
const char * name
Scheme_Object ** names
int num_installed
int num_methods
Scheme_Object * struct_type
Scheme_Object * sup
Scheme_Type type

Define Documentation

#define CONS (   a,
  b 
)    scheme_make_pair(a, b)

Definition at line 604 of file tree.cxx.

#define OBJSCHEME_GET_CPP_OBJ (   obj)    scheme_struct_ref(obj, 0)

Definition at line 295 of file tree.cxx.

#define OBJSCHEME_SET_CPP_OBJ (   obj,
 
)    scheme_struct_set(obj, 0, v)

Definition at line 296 of file tree.cxx.


Typedef Documentation


Function Documentation

static Scheme_Object* class_find_meth ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 730 of file tree.cxx.

{
  Objscheme_Class *sclass = (Objscheme_Class *)argv[0];
  Scheme_Object *s;
  int i;

  if (SCHEME_TYPE(argv[0]) != objscheme_class_type)
    scheme_wrong_type("primitive-class-find-method", "primitive-class", 0, argc, argv);
  if (!SCHEME_SYMBOLP(argv[1]))
    scheme_wrong_type("primitive-class-find-method", "symbol", 1, argc, argv);

  s = argv[1];

  for (i = sclass->num_installed; i--; ) {
    if (SAME_OBJ(sclass->names[i], s))
      return sclass->methods[i];
  }

  return scheme_false;
}

Here is the caller graph for this function:

static Scheme_Object* class_prepare_struct_type ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 623 of file tree.cxx.

{
  Scheme_Object *name, *base_stype, *stype, *derive_stype;
  Scheme_Object **names, **vals, *a[3], *props;
  Objscheme_Class *c;
  int flags, count;

  if (SCHEME_TYPE(argv[0]) != objscheme_class_type)
    scheme_wrong_type("primitive-class-prepare-struct-type!", "primitive-class", 0, argc, argv);
  if (SCHEME_TYPE(argv[1]) != scheme_struct_property_type)
    scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 1, argc, argv);
  scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 3, argc, argv);
  scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv);

  c = ((Objscheme_Class *)argv[0]);
  
  stype = c->struct_type;

  name = scheme_intern_symbol(c->name);

  if (stype) {
    scheme_arg_mismatch("primitive-class-prepare-struct-type!",
                     "struct-type already prepared for primitive-class: ",
                     name);
    return NULL;
  }

  if (SCHEME_TRUEP(c->sup) && !((Objscheme_Class *)c->sup)->base_struct_type) {
    scheme_arg_mismatch("primitive-class-prepare-struct-type!",
                     "super struct-type not yet prepared for primitive-class: ",
                     name);
    return NULL;
  }

  /* Root for this class.  */

  base_stype = scheme_make_struct_type(name, 
                                   (SCHEME_TRUEP(c->sup) 
                                   ? ((Objscheme_Class *)c->sup)->base_struct_type 
                                   : object_struct),
                                   NULL,
                                   0, 0, NULL,
                                   NULL, NULL);
  c->base_struct_type = base_stype;

  /* Type to use when instantiating from C: */

  props = CONS(CONS(object_property, 
                  argv[0]),
              scheme_null);

  stype = scheme_make_struct_type(name,
                              base_stype, 
                              NULL,
                              0, 0, NULL,
                              CONS(CONS(argv[1], argv[2]),
                                   props),
                              NULL);
  
  c->struct_type = stype;
  
  /* Type to derive from Scheme: */
  
  props = CONS(CONS(preparer_property, argv[3]),
              CONS(CONS(dispatcher_property, argv[4]),
                  props));

  derive_stype = scheme_make_struct_type(name,
                                    base_stype, 
                                    NULL,
                                    0, 0, NULL,
                                    props, 
                                    NULL);
  
  /* Type to instantiate from Scheme: */
  
  stype = scheme_make_struct_type(name,
                              base_stype, 
                              NULL,
                              0, 0, NULL,
                              CONS(CONS(argv[1], argv[2]), props),
                              NULL);
  
  /* Need constructor from instantiate type: */
  flags = (SCHEME_STRUCT_NO_TYPE
          | SCHEME_STRUCT_NO_PRED
          | SCHEME_STRUCT_NO_GET
          | SCHEME_STRUCT_NO_SET);
  names = scheme_make_struct_names(name, NULL, flags, &count);
  vals = scheme_make_struct_values(stype, names, count, flags);
  a[0] = vals[0];

  /* Need predicate from base type: */
  flags = (SCHEME_STRUCT_NO_TYPE
          | SCHEME_STRUCT_NO_CONSTR
          | SCHEME_STRUCT_NO_GET
          | SCHEME_STRUCT_NO_SET);
  names = scheme_make_struct_names(name, NULL, flags, &count);
  vals = scheme_make_struct_values(base_stype, names, count, flags);
  a[1] = vals[0];

  /* Need derive type: */
  a[2] = derive_stype;

  return scheme_values(3, a);
}

Here is the caller graph for this function:

void FreeTree ( void scmobj,
void t 
)

Definition at line 299 of file tree.cxx.

{
  Tree::Drop((Tree *)t);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object* Get_Leaves ( int  argc,
Scheme_Object **  argv 
)

Definition at line 450 of file tree.cxx.

{
  Tree *t = (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[0]);
 
  return scheme_make_integer(t->leaves);
}

Here is the caller graph for this function:

Scheme_Object* Get_Left ( int  argc,
Scheme_Object **  argv 
)

Definition at line 436 of file tree.cxx.

{
  Tree *t = (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[0]);
  
  return MarshalTree(t->left_branch);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object* Get_Right ( int  argc,
Scheme_Object **  argv 
)

Definition at line 443 of file tree.cxx.

{ 
  Tree *t = (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[0]);
 
  return MarshalTree(t->right_branch);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object* Graft ( int  argc,
Scheme_Object **  argv 
)

Definition at line 383 of file tree.cxx.

{
  Scheme_Object *obj = argv[0];
  Tree *t, *l, *r;

  if (!SCHEME_FALSEP(argv[1]) && !objscheme_is_a(argv[1], tree_class))
    scheme_wrong_type("tree%'s graft", 
                    "tree% object or #f", 
                    1, argc, argv);
  if (!SCHEME_FALSEP(argv[2]) && !objscheme_is_a(argv[2], tree_class))
    scheme_wrong_type("tree%'s graft", 
                    "tree% object or #f", 
                    2, argc, argv);

  /* Extract the C++ pointer for `this': */
  t = (Tree *)OBJSCHEME_GET_CPP_OBJ(obj);

  /* Extract the C++ pointers for the args: */
  l = (SCHEME_FALSEP(argv[1])
       ? (Tree *)NULL
       : (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[1]));
  r = (SCHEME_FALSEP(argv[2])
       ? (Tree *)NULL
       : (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[2]));
  
  /* Call method: */
  t->Graft(l, r);
  
  return scheme_void;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object* Grow ( int  argc,
Scheme_Object **  argv 
)

Definition at line 334 of file tree.cxx.

{
  Scheme_Object *obj = argv[0];

  if (argc == 2) {
    Tree *t;
    int n;

    if (!SCHEME_INTP(argv[1]))
      scheme_wrong_type("tree%'s grow", 
                     "fixnum", 
                     1, argc, argv);
    n = SCHEME_INT_VAL(argv[1]);
    
    /* Extract the C++ pointer: */
    t = (Tree *)OBJSCHEME_GET_CPP_OBJ(obj);
    
    /* Call method (without override check): */
    t->Tree::Grow(n);
  } else {
    Tree *t;
    char *cmd, *result;

    if (!SCHEME_CHAR_STRINGP(argv[1]))
      scheme_wrong_type("tree%'s grow", 
                     "string", 
                     1, argc, argv);
    if (!SCHEME_BOXP(argv[2])
       || !SCHEME_CHAR_STRINGP(SCHEME_BOX_VAL(argv[2])))
      scheme_wrong_type("tree%'s grow", 
                     "boxed string", 
                     2, argc, argv);

    cmd = scheme_utf8_encode_to_buffer(SCHEME_CHAR_STR_VAL(argv[1]), -1, NULL, 0);
    result = scheme_utf8_encode_to_buffer(SCHEME_CHAR_STR_VAL(SCHEME_BOX_VAL(argv[2])), 1, NULL, 0);

    /* Extract the C++ pointer: */
    t = (Tree *)OBJSCHEME_GET_CPP_OBJ(obj);
    
    /* Call method (without override check): */
    t->Tree::Grow(cmd, result);

    /* Put result back in box: */
    SCHEME_BOX_VAL(argv[2]) = scheme_make_utf8_string(result);
  }
  
  return scheme_void;
}

Here is the caller graph for this function:

static Scheme_Object* init_prim_obj ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 609 of file tree.cxx.

{
  Objscheme_Class *c;
  Scheme_Object *obj = argv[0];

  if (!SCHEME_STRUCTP(argv[0])
      || !scheme_is_struct_instance(object_struct, argv[0]))
    scheme_wrong_type("initialize-primitive-object", "primitive-object", 0, argc, argv);
  
  c = (Objscheme_Class *)scheme_struct_type_property_ref(object_property, obj);

  return _scheme_apply(c->initf, argc, argv);
}

Here is the caller graph for this function:

Scheme_Object* Make_Tree ( int  argc,
Scheme_Object **  argv 
)

Definition at line 304 of file tree.cxx.

{
  Scheme_Object *obj;

  /* Unfortunately, init arity is not automatically checked: */
  if (argc != 2)
    scheme_wrong_count("tree% initialization", 2, 2, argc, argv);

  /* Assuming the initializer is only called through
     the class interface, argv[0] is always ok: */
  obj = argv[0];

  if (!SCHEME_INTP(argv[1]))
    scheme_wrong_type("tree% initialization", 
                    "fixnum", 
                    1, argc, argv);

  /* Create C++ instance, and remember pointer back to Scheme instance: */
  Tree *t = new mzTree(SCHEME_INT_VAL(argv[1]));
  t->user_data = obj;

  /* Store C++ pointer in Scheme object: */
  OBJSCHEME_SET_CPP_OBJ(obj, (Scheme_Object *)t);

  /* Free C++ instance when the Scheme object is no longer referenced: */
  scheme_add_finalizer(obj, FreeTree, t);

  return obj;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 414 of file tree.cxx.

{
  if (!t)
    return scheme_false;
  else if (!t->user_data) {
    /* Object created in C++, not seen by Scheme, yet.
       Create a Scheme version of this object. */
    Scheme_Object *scmobj;

    /* Make Scheme object: */
    scmobj = objscheme_make_uninited_object(tree_class);

    /* Link C++ and Scheme objects: */
    t->user_data = scmobj;
    OBJSCHEME_SET_CPP_OBJ(scmobj, (Scheme_Object *)t);
    
    return scmobj;
  } else
    /* Get pointer back to Scheme: */
    return (Scheme_Object *)t->user_data;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object * objscheme_add_method_w_arity ( Scheme_Object c,
const char *  name,
Scheme_Prim f,
int  mina,
int  maxa 
)

Definition at line 802 of file tree.cxx.

{
  Scheme_Object *s;
  Objscheme_Class *sclass;

  sclass = (Objscheme_Class *)c;

  s = scheme_make_prim_w_arity(f, name, mina + 1, (maxa < 0) ? -1 : (maxa + 1));

  sclass->methods[sclass->num_installed] = s;

  s = scheme_intern_symbol(name);

  sclass->names[sclass->num_installed] = s;

  sclass->num_installed++;

  return s;
}

Here is the caller graph for this function:

Definition at line 863 of file tree.cxx.

{
  scheme_add_global("initialize-primitive-object",
                  scheme_make_prim_w_arity(init_prim_obj,
                                        "initialize-primitive-object",
                                        1, -1),
                  env);

  scheme_add_global("primitive-class-prepare-struct-type!",
                  scheme_make_prim_w_arity(class_prepare_struct_type,
                                        "primitive-class-prepare-struct-type!",
                                        5, 5),
                  env);
  
  scheme_add_global("primitive-class-find-method",
                  scheme_make_prim_w_arity(class_find_meth,
                                        "primitive-class-find-method",
                                        2, 2),
                  env);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object * objscheme_find_method ( Scheme_Object obj,
char *  name,
void **  cache 
)

Definition at line 884 of file tree.cxx.

{
  Scheme_Object *s, *p[2], *dispatcher;

  if (!obj)
    return NULL;

  dispatcher = scheme_struct_type_property_ref(dispatcher_property, (Scheme_Object *)obj);
  if (!dispatcher)
    return NULL;

  if (*cache)
    s = (Scheme_Object *)*cache;
  else {
    s = scheme_intern_symbol(name);
    p[0] = s;
    s = scheme_struct_type_property_ref(preparer_property, (Scheme_Object *)obj);
    if (!s)
      return NULL;
    s = scheme_apply(s, 1, p);
    scheme_register_extension_global((void *)cache, sizeof(Scheme_Object*));
    *cache = s;
  }

  p[0] = obj;
  p[1] = s;
  return _scheme_apply(dispatcher, 2, p);
}

Definition at line 839 of file tree.cxx.

{
  objscheme_class_type = scheme_make_type("<primitive-class>");

  /* Attaches a primitive class to an object: */
  scheme_register_extension_global(&object_property, sizeof(object_property));
  object_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-object"));
  
  /* Attaches a preparer function to a derived class: */
  scheme_register_extension_global(&preparer_property, sizeof(preparer_property));
  preparer_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-preparer"));

  /* Attaches a dispatcher function to a derived class: */
  scheme_register_extension_global(&dispatcher_property, sizeof(dispatcher_property));
  dispatcher_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-dispatcher"));

  /* The base struct type for the Scheme view of a primitive object: */
  scheme_register_extension_global(&object_struct, sizeof(object_struct));
  object_struct = scheme_make_struct_type(scheme_intern_symbol("primitive-object"), 
                                     NULL, NULL,
                                     0, 2, NULL,
                                     NULL, NULL);
}

Here is the caller graph for this function:

Definition at line 823 of file tree.cxx.

{
  Scheme_Object *a;

  if (!SCHEME_STRUCTP(o) || !scheme_is_struct_instance(object_struct, o))
    return 0;

  a = scheme_struct_type_property_ref(object_property, o);
  
  while (a && (a != c)) {
    a = ((Objscheme_Class *)a)->sup;
  }

  return !!a;
}
Scheme_Object * objscheme_make_class ( const char *  name,
Scheme_Object sup,
Scheme_Prim initf,
int  num_methods 
)

Definition at line 772 of file tree.cxx.

{
  Objscheme_Class *sclass;
  Scheme_Object *f, **methods, **names;

  sclass = (Objscheme_Class *)scheme_malloc_tagged(sizeof(Objscheme_Class));
  sclass->type = objscheme_class_type;

  if (!sup)
    sup = scheme_false;

  sclass->name = name;
  sclass->sup = sup;

  f = scheme_make_prim(initf);
  sclass->initf = f;

  sclass->num_methods = num_methods;
  sclass->num_installed = 0;

  methods = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object *) * num_methods);
  names = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object *) * num_methods);

  sclass->methods = methods;
  sclass->names = names;

  return (Scheme_Object *)sclass;
}

Here is the caller graph for this function:

Definition at line 751 of file tree.cxx.

{
  Scheme_Object *obj;
  Scheme_Object *stype;

  stype = ((Objscheme_Class *)sclass)->struct_type;
  if (!stype) {
    scheme_arg_mismatch("make-primitive-object",
                     "struct-type not yet prepared: ",
                     sclass);
    return NULL;
  }

  obj = scheme_make_struct_instance(stype, 0, NULL);

  return obj;  
}

Here is the caller graph for this function:

Definition at line 470 of file tree.cxx.

Here is the call graph for this function:

Definition at line 499 of file tree.cxx.

{
  /* This extension doesn't define a module: */
  return scheme_false;
}

Definition at line 461 of file tree.cxx.

{
  scheme_add_global("tree-primitive-class", tree_class, env);

  objscheme_add_procedures(env);

  return scheme_void;
}

Here is the call graph for this function:


Variable Documentation

Definition at line 602 of file tree.cxx.

Definition at line 214 of file tree.cxx.

Definition at line 216 of file tree.cxx.

Definition at line 600 of file tree.cxx.

Definition at line 599 of file tree.cxx.

Definition at line 597 of file tree.cxx.

Definition at line 601 of file tree.cxx.

Definition at line 212 of file tree.cxx.