/* HOC extension class wrapper for cis */ /* This module defines a HOC class, IntegerSet, which provides access * to the functionality of the Chicken cis library. * * The following API is available: * * 1. Constructors * * IntegerSet(): creates an empty integer set * IntegerSet(N): creates a singleton integer set containing N * IntegerSet(M,N): creates an integer interval [M,N] * * 2. Predicates * * x.is_empty(): returns 1 if IntegerSet object x is empty, 0 otherwise * x.is_subset(y): returns 1 if IntegerSet object y is a subset of * IntegerSet object x, 0 otherwise * * 3. Accessors * */ #include #include #include #include "scoplib.h" /* NEURON specific declarations */ /* the following unfortunate hackery is needed to avoid collisions with identifiers in chicken.h */ #undef t #undef dt #undef _nd_area #include #define t nrn_threads->_t #define dt nrn_threads->_dt #define _nd_area *_ppvar[0]._pval typedef struct Object { int refcount; /* how many object variables point to this */ int index; /* unique integer used for names of sections */ void* this_pointer; /* the c++ object */ } Object_t; extern char* gargstr(int); extern double* getarg(int); extern double chkarg(int, double min, double max); extern int ifarg(int); extern void** hoc_objgetarg(int); /* End of NEURON specific declarations */ static int cis_initialized = 0; #define cis_ndata 15 /* A vector with pointers to the Scheme cis procedures. This is * necessary in order to prevent the garbage collector from moving * the procedures in memory and changing their entry addresses. (See * call to C_gc_protect below). */ C_word *cis_data[ cis_ndata ]; static C_word cis_empty = C_SCHEME_UNDEFINED; static C_word cis_singleton = C_SCHEME_UNDEFINED; static C_word cis_interval = C_SCHEME_UNDEFINED; static C_word cis_is_empty = C_SCHEME_UNDEFINED; static C_word cis_is_subset = C_SCHEME_UNDEFINED; static C_word cis_cardinal = C_SCHEME_UNDEFINED; static C_word cis_get_min = C_SCHEME_UNDEFINED; static C_word cis_get_max = C_SCHEME_UNDEFINED; static C_word cis_in = C_SCHEME_UNDEFINED; static C_word cis_add = C_SCHEME_UNDEFINED; static C_word cis_remove = C_SCHEME_UNDEFINED; static C_word cis_shift = C_SCHEME_UNDEFINED; static C_word cis_union = C_SCHEME_UNDEFINED; static C_word cis_intersection = C_SCHEME_UNDEFINED; static C_word cis_difference = C_SCHEME_UNDEFINED; void chicken_print_error () { char *msg; msg = (char *)malloc(512); CHICKEN_get_error_message (msg, 511); printf("CHICKEN error: %s\n", msg); } int cis_initialize () { int status; C_word val; char msg[512]; C_word *ptr, list, is; if (cis_initialized == 0) { assert (status = CHICKEN_initialize (0, 1024*1024, 0, CHICKEN_default_toplevel)); assert (status = CHICKEN_run (NULL)); assert (status = CHICKEN_eval_string ("(require-extension cis)", &val)); assert (status = CHICKEN_eval_string ("empty", &cis_empty)); cis_data[0] = &cis_empty; C_gc_protect (cis_data+0, 1); assert (status = CHICKEN_eval_string ("(lambda (x) (gc) (singleton x) )", &cis_singleton)); cis_data[1] = &cis_singleton; C_gc_protect (cis_data+1, 1); assert (status = CHICKEN_eval_string ("(lambda (x y) (gc) (interval x y))", &cis_interval)); cis_data[2] = &cis_interval; C_gc_protect (cis_data+2, 1); assert (status = CHICKEN_eval_string ("(lambda (x) (gc) (empty? x))", &cis_is_empty)); cis_data[3] = &cis_is_empty; C_gc_protect (cis_data+3, 1); assert (status = CHICKEN_eval_string ("(lambda (x y) (gc) (subset? x y))", &cis_is_subset)); cis_data[4] = &cis_is_subset; C_gc_protect (cis_data+4, 1); assert (status = CHICKEN_eval_string ("(lambda (x) (gc) (cardinal x ))", &cis_cardinal)); cis_data[5] = &cis_cardinal; C_gc_protect (cis_data+5, 1); assert (status = CHICKEN_eval_string ("(lambda (x) (gc) (get-min x ))", &cis_get_min)); cis_data[6] = &cis_get_min; C_gc_protect (cis_data+6, 1); assert (status = CHICKEN_eval_string ("(lambda (x) (gc) (get-max x ))", &cis_get_max)); cis_data[7] = &cis_get_max; C_gc_protect (cis_data+7, 1); assert (status = CHICKEN_eval_string ("(lambda (i x) (gc) (in? i x ))", &cis_in)); cis_data[8] = &cis_in; C_gc_protect (cis_data+8, 1); assert (status = CHICKEN_eval_string ("(lambda (i x) (gc) (add i x ))", &cis_add)); cis_data[9] = &cis_add; C_gc_protect (cis_data+9, 1); assert (status = CHICKEN_eval_string ("(lambda (i x) (gc) (remove i x ))", &cis_remove)); cis_data[10] = &cis_remove; C_gc_protect (cis_data+10, 1); assert (status = CHICKEN_eval_string ("(lambda (i x) (gc) (shift i x ))", &cis_shift)); cis_data[11] = &cis_shift; C_gc_protect (cis_data+11, 1); assert (status = CHICKEN_eval_string ("(lambda (x y) (gc) (union i x ))", &cis_union)); cis_data[12] = &cis_union; C_gc_protect (cis_data+12, 1); assert (status = CHICKEN_eval_string ("(lambda (x y) (gc) (intersection i x ))", &cis_intersection)); cis_data[13] = &cis_intersection; C_gc_protect (cis_data+13, 1); assert (status = CHICKEN_eval_string ("(lambda (x y) (gc) (difference i x ))", &cis_difference)); cis_data[14] = &cis_difference; C_gc_protect (cis_data+14, 1); cis_initialized = 1; } return status; } static void* is_construct (void *o) { C_word is, list, res, *ptr; int status, x, y; void *root; char msg[512]; if (ifarg(2)) { x = (int)chkarg(1,0,1e8); y = (int)chkarg(2,0,1e8); ptr = C_alloc (C_SIZEOF_LIST(2)); list = C_list(&ptr, 2, C_fix(x), C_fix(y)); status = CHICKEN_apply (cis_interval, list, &is); if (status == 0) { CHICKEN_get_error_message (msg, 511); printf ("is_construct: error %s\n", msg); } assert (status); } else if (ifarg(1)) { x = (int)chkarg(1,0,1e8); ptr = C_alloc (C_SIZEOF_LIST(1)); list = C_list(&ptr, 1, C_fix(x)); assert (status = CHICKEN_apply (cis_singleton, list, &is)); } else { is = cis_empty; } root = CHICKEN_new_gc_root (); CHICKEN_gc_root_set (root, is); return root; } static void is_destruct(void* v) { CHICKEN_delete_gc_root (v); } static double is_is_empty (void *v) { int status; C_word val, obj, list; C_word *ptr; obj = CHICKEN_gc_root_ref(v); assert(C_truep(C_pairp(obj))); ptr = C_alloc (C_SIZEOF_LIST(1)); list = C_list(&ptr, 1, obj); if ((status = CHICKEN_apply (cis_is_empty, list, &val)) == 0) { chicken_print_error(); abort(); } return C_truep(val); } static double is_is_subset (void *v) { int status; C_word val, x, y, list; C_word *ptr; x = CHICKEN_gc_root_ref(v); y = CHICKEN_gc_root_ref(((Object_t *)(*hoc_objgetarg(1)))->this_pointer); assert(C_truep(C_pairp(x))); assert(C_truep(C_pairp(y))); ptr = C_alloc (C_SIZEOF_LIST(2)); list = C_list(&ptr, 2, y, x); if ((status = CHICKEN_apply (cis_is_subset, list, &val)) == 0) { chicken_print_error(); abort(); } return C_truep(val); } static struct Member_func { char* _name; double (*_member)();} is_members[] = { "is_empty", is_is_empty, "is_subset", is_is_subset, 0, 0 }; extern void class2oc(char*, void* (*cons)(void*), void (*destruct)(void*), void*, void*, void*, void*); void IntegerSet_reg() { cis_initialize(); class2oc("IntegerSet", is_construct, is_destruct, is_members, NULL, NULL, NULL); printf("IntegerSet registered\n"); } void modl_reg() { IntegerSet_reg(); }