diff --git a/collects/mzscheme/examples/README b/collects/mzscheme/examples/README index 9791740460..fdd4a8052a 100644 --- a/collects/mzscheme/examples/README +++ b/collects/mzscheme/examples/README @@ -3,41 +3,45 @@ examples are implemented directly in C. A few examples listed at the end use the mzc `c-lambda', etc. forms. * hello.c - returns the string "Hello, World!". Demonstrates creating - a Scheme value. (Works with 3m.) + a Scheme value. * fmod.c - defines the `fmod' procedure, which calculates modulo on floating-point numbers. Demonstrates creating Scheme procedures - from C and adding top-level definitions. (Works with 3m.) + from C and adding top-level definitions. (Manually instrumented for + 3m, so do not use `mzc --xform'.) * curses.c - links MzScheme to the curses library. Demonstrates more procedures and definitions, a little more type dispatching, and - returning multiple values. (Works with 3m.) + returning multiple values. (Manually instrumented for 3m, so do not + use `mzc --xform'.) * makeadder.c - defines `make-adder', which takes a number and returns a procedure that takes another number to add to it. Demonstrates closure creation in C, getting Scheme global values, and calling Scheme procedures from C. - makeadder3m.c - the same, but works with 3m. Making the code - work with 3m requires several changes. + makeadder3m.c - the same, but manually instrumented 3m (so do not + use `mzc --xform'). Making the code work with 3m requires several + changes, but `mzc --xform' works on "makeadder.c" without changes. * catch.c - defined `eval-string/catch-error', which catches excpetions whil evaluating a string. Demonstrates how to catch - exceptions from C code. (Does not work with 3m.) + exceptions from C code. * bitmatrix.c - implements two-dimentional bit matrixes with some operations. Demonstrates defining a new Scheme data type, data allocation, fancy integer type checking, general exception raising, - and registering static variables. (Does not work with 3m.) + and registering static variables. Also demonstrates supplying + traversal functions for 3m (but still needs `mzc --xform' + preprocessing to build for 3m). * idmodule.c - Declares the module named `idmodule' that provides an `identity' function. Demonstrates implementing a primitive module - in C. (Does not work with 3m.) + in C. * helloprint.c - prints "Hello, World!" directly to the current output port rather than relying on the read-eval-print-loop. - Demonstrates using built-in Scheme parameter values from C. (Does - not work with 3m.) + Demonstrates using built-in Scheme parameter values from C. * tree.cxx, tree-finish.ss - shows how to inject a C++ class into MzLib's class.ss world. (Does not work with 3m.) diff --git a/collects/mzscheme/examples/bitmatrix.c b/collects/mzscheme/examples/bitmatrix.c index 27653db323..6e9eefb8bd 100644 --- a/collects/mzscheme/examples/bitmatrix.c +++ b/collects/mzscheme/examples/bitmatrix.c @@ -27,6 +27,23 @@ typedef struct { unsigned long *matrix; } Bitmatrix; +#ifdef MZ_PRECISE_GC +START_XFORM_SKIP; +/* Traversal procedures for precise GC: */ +static long bm_size(void *p) { + return gcBYTES_TO_WORDS(sizeof(Bitmatrix)); +} +static long bm_mark(void *p) { + gcMARK(((Bitmatrix *)p)->matrix); + return gcBYTES_TO_WORDS(sizeof(Bitmatrix)); +} +static long bm_fixup(void *p) { + gcFIXUP(((Bitmatrix *)p)->matrix); + return gcBYTES_TO_WORDS(sizeof(Bitmatrix)); +} +END_XFORM_SKIP; +#endif + /* We'll get some Scheme primitives so we can calculate with numbers taht are potentially bignums: */ static Scheme_Object *mult, *add, *sub, *modulo, *neg; @@ -51,7 +68,7 @@ static int negative(Scheme_Object *o) Scheme_Object *make_bit_matrix(int argc, Scheme_Object **argv) { Scheme_Object *size, *rowlength, *a[2]; - unsigned long w, h, s, l; + unsigned long w, h, s, l, *lp; Bitmatrix *bm; /* Really fancy: we allow any kind of positive integer for @@ -92,25 +109,27 @@ Scheme_Object *make_bit_matrix(int argc, Scheme_Object **argv) /* Malloc the bit matrix structure. Since we use scheme_malloc, the bit matrix value is GC-able. */ - bm = (Bitmatrix *)scheme_malloc(sizeof(Bitmatrix)); + bm = (Bitmatrix *)scheme_malloc_tagged(sizeof(Bitmatrix)); bm->type = bitmatrix_type; /* Try to allocate the bit matrix. Handle failure gracefully. Note that we use scheme_malloc_atomic since the allocated memory will never contain pointers to GC-allocated memory. */ s = ((s + LONG_SIZE - 1) >> LOG_LONG_SIZE); - bm->matrix = (unsigned long *)scheme_malloc_fail_ok(scheme_malloc_atomic, - sizeof(long) * s); - if (!bm->matrix) + lp = (unsigned long *)scheme_malloc_fail_ok(scheme_malloc_atomic, + sizeof(long) * s); + if (!lp) scheme_raise_exn(MZEXN_FAIL, "make-bit-matrix: out of memory"); + bm->matrix = lp; bm->w = w; bm->h = h; bm->l = l; /* Init matirx to all 0s: */ - while (s--) + while (s--) { bm->matrix[s] = 0; + } return (Scheme_Object *)bm; } @@ -207,10 +226,11 @@ Scheme_Object *bit_matrix_invert(int argc, Scheme_Object **argv) scheme_wrong_type("bit-matrix-invert!", "bit-matrix", 0, argc, argv); bm = (Bitmatrix *)argv[0]; - + i = (bm->l * bm->h) >> LOG_LONG_SIZE; - while (i--) + while (i--) { bm->matrix[i] = ~bm->matrix[i]; + } return scheme_void; } @@ -228,8 +248,9 @@ Scheme_Object *bit_matrix_clear(int argc, Scheme_Object **argv) bm = (Bitmatrix *)argv[0]; i = (bm->l * bm->h) >> LOG_LONG_SIZE; - while (i--) + while (i--) { bm->matrix[i] = 0; + } return scheme_void; } @@ -275,6 +296,11 @@ Scheme_Object *scheme_initialize(Scheme_Env *env) { bitmatrix_type = scheme_make_type(""); +#ifdef MZ_PRECISE_GC + /* Register traversal procedures: */ + GC_register_traversers(bitmatrix_type, bm_size, bm_mark, bm_fixup, 1, 0); +#endif + /* Get some Scheme primitives. Conservative garbage collection sees any local variables we use within a function, but we have to register static variables: */ diff --git a/collects/mzscheme/examples/catch.c b/collects/mzscheme/examples/catch.c index e1c347c5ba..3de23ca7d9 100644 --- a/collects/mzscheme/examples/catch.c +++ b/collects/mzscheme/examples/catch.c @@ -29,12 +29,14 @@ static Scheme_Object *exn_catching_apply, *exn_p, *exn_message; static void init_exn_catching_apply() { if (!exn_catching_apply) { + Scheme_Env *env; char *e = "(lambda (thunk) " "(with-handlers ([void (lambda (exn) (cons #f exn))]) " "(cons #t (thunk))))"; + /* make sure we have a namespace with the standard bindings: */ - Scheme_Env *env = (Scheme_Env *)scheme_make_namespace(0, NULL); + env = (Scheme_Env *)scheme_make_namespace(0, NULL); scheme_register_extension_global(&exn_catching_apply, sizeof(Scheme_Object *)); scheme_register_extension_global(&exn_p, sizeof(Scheme_Object *)); diff --git a/collects/mzscheme/examples/helloprint.c b/collects/mzscheme/examples/helloprint.c index 69b28c34a6..0bbaf68074 100644 --- a/collects/mzscheme/examples/helloprint.c +++ b/collects/mzscheme/examples/helloprint.c @@ -6,7 +6,8 @@ Scheme_Object *scheme_reload(Scheme_Env *env) { /* Make the string: */ - Scheme_Object *hw = scheme_make_utf8_string("Hello, World!\n"); + Scheme_Object *hw; + hw = scheme_make_utf8_string("Hello, World!\n"); /* Display it: */ scheme_display(hw, scheme_get_param(scheme_current_config(),