Back to index

plt-scheme  4.2.1
bitmatrix.c
Go to the documentation of this file.
00001 /* 
00002 
00003    This extension Defines a new type of Scheme data: a two-dimensional
00004    matrix of bits.
00005    
00006    A client using this extension would look something like this:
00007 
00008       (load-extension "bitmatrix.so")
00009       (define bm (make-bit-matrix 1000 1000))
00010       ...
00011       (bit-matrix-set! bm 500 500 #t)
00012       ...
00013       (if (bit-matrix-get bm 500 500) ...)
00014       ...
00015 
00016 */
00017 
00018 #include "escheme.h"
00019 
00020 /* Instances of this Bitmatrix structure will be the Scheme bit matirx
00021    values: */
00022 typedef struct {
00023   Scheme_Object so; /* Every Scheme value starts with a Scheme_Object,
00024                        which stars with a type tag.  The
00025                      format for the rest of the structure is
00026                      anything we want it to be. */
00027   unsigned long w, h, l; /* l = w rounded to multiple of LONG_SIZE */
00028   unsigned long *matrix;
00029 } Bitmatrix;
00030 
00031 #ifdef MZ_PRECISE_GC
00032 START_XFORM_SKIP;
00033 /* Traversal procedures for precise GC: */
00034 static int bm_size(void *p) { 
00035   return gcBYTES_TO_WORDS(sizeof(Bitmatrix)); 
00036 }
00037 static int bm_mark(void *p) { 
00038   gcMARK(((Bitmatrix *)p)->matrix);
00039   return gcBYTES_TO_WORDS(sizeof(Bitmatrix));
00040 }
00041 static int bm_fixup(void *p) { 
00042   gcFIXUP(((Bitmatrix *)p)->matrix);
00043   return gcBYTES_TO_WORDS(sizeof(Bitmatrix));
00044 }
00045 END_XFORM_SKIP;
00046 #endif
00047 
00048 /* We'll get some Scheme primitives so we can calculate with numbers
00049    taht are potentially bignums: */
00050 static Scheme_Object *mult, *add, *sub, *modulo, *neg;
00051 
00052 /* The type tag for bit matrixes, initialized with scheme_make_type */
00053 static Scheme_Type bitmatrix_type;
00054 
00055 #define LONG_SIZE 32
00056 #define LOG_LONG_SIZE 5
00057 #define LONG_SIZE_PER_BYTE 4
00058 
00059 # define FIND_BIT(p) (1 << (p & (LONG_SIZE - 1)))
00060 
00061 /* Helper function to check whether an integer (fixnum or bignum) is
00062    negative: */
00063 static int negative(Scheme_Object *o)
00064 {
00065   return SCHEME_TRUEP(_scheme_apply(neg, 1, &o));
00066 }
00067 
00068 /* Scheme procedure to make a bit matrix: */
00069 Scheme_Object *make_bit_matrix(int argc, Scheme_Object **argv)
00070 {
00071   Scheme_Object *size, *rowlength, *a[2];
00072   unsigned long w, h, s, l, *lp;
00073   Bitmatrix *bm;
00074 
00075   /* Really fancy: we allow any kind of positive integer for
00076      specifying the size of a bit matrix. If we get a bignum (or the
00077      resulting matrix size is a bignum), we'll signal an out-of-memory
00078      exception. */
00079   if ((!SCHEME_INTP(argv[0])  && !SCHEME_BIGNUMP(argv[0]))
00080       || negative(argv[0]))
00081     scheme_wrong_type("make-bit-matrix", "positive integer", 0, argc, argv);
00082   if ((!SCHEME_INTP(argv[1])  && !SCHEME_BIGNUMP(argv[1]))
00083       || (negative(argv[1])))
00084     scheme_wrong_type("make-bit-matrix", "positive integer", 1, argc, argv);
00085 
00086   a[0] = argv[0];
00087   a[1] = scheme_make_integer(LONG_SIZE - 1);
00088   /* Apply the Scheme `add' procedure to argv[0] and argv[1]. Note the
00089      "_" in "_scheme_apply"; that's a lot faster than "scheme_apply",
00090      and we know that no continuation jumps will occur (although it
00091      would be fine if one did. */
00092   a[0] = _scheme_apply(add, 2, a);
00093   a[1] = scheme_make_integer(LONG_SIZE);
00094   a[1] = _scheme_apply(modulo, 2, a);
00095   a[0] = _scheme_apply(sub, 2, a);
00096   rowlength = a[0];
00097   a[1] = argv[1];
00098   size = _scheme_apply(mult, 2, a);
00099   if (SCHEME_BIGNUMP(size))
00100     /* Use scheme_raise_exn to raise exceptions. The first argument
00101        describes the type of the exception. After an exception-specific
00102        number of Scheme values (none in this case), the rest of the
00103        arguments are like printf. */
00104     scheme_raise_exn(MZEXN_FAIL, "make-bit-matrix: out of memory");
00105   
00106   s = SCHEME_INT_VAL(size);
00107   w = SCHEME_INT_VAL(argv[0]);
00108   h = SCHEME_INT_VAL(argv[1]);
00109   l = SCHEME_INT_VAL(rowlength);
00110 
00111   /* Malloc the bit matrix structure. Since we use scheme_malloc, the
00112      bit matrix value is GC-able. */
00113   bm = (Bitmatrix *)scheme_malloc_tagged(sizeof(Bitmatrix));
00114   bm->so.type = bitmatrix_type;
00115 
00116   /* Try to allocate the bit matrix. Handle failure gracefully. Note
00117      that we use scheme_malloc_atomic since the allocated memory will
00118      never contain pointers to GC-allocated memory. */
00119   s = ((s + LONG_SIZE - 1) >> LOG_LONG_SIZE);
00120   lp = (unsigned long *)scheme_malloc_fail_ok(scheme_malloc_atomic, 
00121                                          sizeof(long) * s);
00122   if (!lp)
00123     scheme_raise_exn(MZEXN_FAIL, "make-bit-matrix: out of memory");
00124   bm->matrix = lp;
00125 
00126   bm->w = w;
00127   bm->h = h;
00128   bm->l = l;
00129 
00130   /* Init matirx to all 0s: */
00131   while (s--) {
00132     bm->matrix[s] = 0;
00133   }
00134 
00135   return (Scheme_Object *)bm;
00136 }
00137 
00138 /* Internal utility function for error-checking with a fancy error
00139    message: */
00140 static void range_check_one(char *name, char *which, 
00141                          int l, int h, int startpos, 
00142                          int argc, Scheme_Object **argv)
00143 {
00144   int bad1;
00145 
00146   if (SCHEME_BIGNUMP(argv[startpos])) {
00147     bad1 = 1;
00148   } else {
00149     int v = SCHEME_INT_VAL(argv[startpos]);
00150     bad1 = ((v < l) || (v > h));
00151   }
00152 
00153   if (bad1) {
00154     /* A mismatch exception requires one Scheme value, so we provide
00155        it before the printf string: */
00156     char *args;
00157     long argslen;
00158 
00159     args = scheme_make_args_string("other ", startpos, argc, argv, &argslen);
00160     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
00161                    "%s: %s index %s is not in the range [%d,%d]%t",
00162                    name, which,
00163                    scheme_make_provided_string(argv[startpos], 1, NULL),
00164                    l, h,
00165                    args,
00166                    argslen);
00167   }
00168 }
00169 
00170 /* Internal utility function that implements most of the work of the
00171    get- and set- Scheme procedures: */
00172 static Scheme_Object *do_bit_matrix(char *name, int get, int argc, Scheme_Object **argv)
00173 {
00174   Bitmatrix *bm;
00175   unsigned long x, y, p, v, m;
00176 
00177   if (SCHEME_TYPE(argv[0]) != bitmatrix_type)
00178     scheme_wrong_type(name, "bit-matrix", 0, argc, argv);
00179   if (!SCHEME_INTP(argv[1])  && !SCHEME_BIGNUMP(argv[1]))
00180     scheme_wrong_type(name, "integer", 1, argc, argv);
00181   if (!SCHEME_INTP(argv[2])  && !SCHEME_BIGNUMP(argv[2]))
00182     scheme_wrong_type(name, "integer", 2, argc, argv);
00183 
00184   /* After checking that argv[0] has te bitmatrix_type tag, we can safely perform
00185      a cast to Bitmatrix*: */
00186   bm = (Bitmatrix *)argv[0];
00187 
00188   range_check_one(name, "first", 0, bm->w - 1, 1, argc, argv);
00189   range_check_one(name, "second", 0, bm->h - 1, 2, argc, argv);
00190 
00191   x = SCHEME_INT_VAL(argv[1]);
00192   y = SCHEME_INT_VAL(argv[2]);
00193 
00194   p = y * bm->l + x;
00195   m = FIND_BIT(p);
00196   v = bm->matrix[p >> LOG_LONG_SIZE];
00197   if (get) {
00198     return (v & m) ? scheme_true : scheme_false;
00199   } else {
00200     if (SCHEME_TRUEP(argv[3]))
00201       bm->matrix[p >> LOG_LONG_SIZE] = (v | m);
00202     else
00203       bm->matrix[p >> LOG_LONG_SIZE] = (v - (v & m));
00204     return scheme_void;
00205   }
00206 }
00207 
00208 /* Scheme procedure: get a bit from the matrix */
00209 Scheme_Object *bit_matrix_get(int argc, Scheme_Object **argv)
00210 {
00211   return do_bit_matrix("bit-matrix-get", 1, argc, argv);
00212 }
00213 
00214 /* Scheme procedure: set a bit in the matrix */
00215 Scheme_Object *bit_matrix_set(int argc, Scheme_Object **argv)
00216 {
00217   return do_bit_matrix("bit-matrix-set!", 0, argc, argv);
00218 }
00219 
00220 /* Scheme procedure: invert the whole matrix */
00221 Scheme_Object *bit_matrix_invert(int argc, Scheme_Object **argv)
00222 {
00223   Bitmatrix *bm;
00224   unsigned long i;
00225 
00226   if (SCHEME_TYPE(argv[0]) != bitmatrix_type)
00227     scheme_wrong_type("bit-matrix-invert!", "bit-matrix", 0, argc, argv);
00228 
00229   bm = (Bitmatrix *)argv[0];
00230   
00231   i = (bm->l * bm->h) >> LOG_LONG_SIZE;
00232   while (i--) {
00233     bm->matrix[i] = ~bm->matrix[i];
00234   }
00235 
00236   return scheme_void;
00237 }
00238 
00239 /* Scheme procedure: clear the whole matrix */
00240 Scheme_Object *bit_matrix_clear(int argc, Scheme_Object **argv)
00241 {
00242   char *name = "bit-matrix-clear!";
00243   Bitmatrix *bm;
00244   unsigned long i;
00245 
00246   if (SCHEME_TYPE(argv[0]) != bitmatrix_type)
00247     scheme_wrong_type(name, "bit-matrix", 0, argc, argv);
00248 
00249   bm = (Bitmatrix *)argv[0];
00250 
00251   i = (bm->l * bm->h) >> LOG_LONG_SIZE;
00252   while (i--) {
00253     bm->matrix[i] = 0;
00254   }
00255 
00256   return scheme_void;
00257 }
00258 
00259 Scheme_Object *scheme_reload(Scheme_Env *env)
00260 {
00261   /* Define our new primitives: */
00262 
00263   scheme_add_global("make-bit-matrix",
00264                   scheme_make_prim_w_arity(make_bit_matrix,
00265                                         "make-bit-matrix",
00266                                         2, 2),
00267                   env);
00268 
00269   scheme_add_global("bit-matrix-get",
00270                   scheme_make_prim_w_arity(bit_matrix_get,
00271                                         "bit-matrix-get",
00272                                         3, 3),
00273                   env);
00274 
00275   scheme_add_global("bit-matrix-set!",
00276                   scheme_make_prim_w_arity(bit_matrix_set,
00277                                         "bit-matrix-set!",
00278                                         4, 4),
00279                   env);
00280 
00281   scheme_add_global("bit-matrix-invert!",
00282                   scheme_make_prim_w_arity(bit_matrix_invert,
00283                                         "bit-matrix-invert!",
00284                                         1, 1),
00285                   env);
00286 
00287   scheme_add_global("bit-matrix-clear!",
00288                   scheme_make_prim_w_arity(bit_matrix_clear,
00289                                         "bit-matrix-clear!",
00290                                         1, 1),
00291                   env);
00292 
00293   return scheme_void;
00294 }
00295 
00296 Scheme_Object *scheme_initialize(Scheme_Env *env)
00297 {
00298   bitmatrix_type = scheme_make_type("<bit-matrix>");
00299 
00300 #ifdef MZ_PRECISE_GC
00301   /* Register traversal procedures: */
00302   GC_register_traversers(bitmatrix_type, bm_size, bm_mark, bm_fixup, 1, 0);
00303 #endif
00304 
00305   /* Get some Scheme primitives. Conservative garbage collection sees
00306      any local variables we use within a function, but we have to register
00307      static variables: */
00308 
00309   scheme_register_extension_global(&mult, sizeof(Scheme_Object*));
00310   mult = scheme_builtin_value("*");
00311 
00312   scheme_register_extension_global(&add, sizeof(Scheme_Object*));
00313   add = scheme_builtin_value("+");
00314 
00315   scheme_register_extension_global(&sub, sizeof(Scheme_Object*));
00316   sub = scheme_builtin_value("-");
00317 
00318   scheme_register_extension_global(&modulo, sizeof(Scheme_Object*));
00319   modulo = scheme_builtin_value("modulo");
00320 
00321   scheme_register_extension_global(&neg, sizeof(Scheme_Object*));
00322   neg = scheme_builtin_value("negative?");
00323 
00324   return scheme_reload(env);
00325 }
00326 
00327 
00328 Scheme_Object *scheme_module_name()
00329 {
00330   /* This extension doesn't define a module: */
00331   return scheme_false;
00332 }