Add exception handler fix

* tests/base.scm: add two tests for issue #556

The two tests are adapted from issue #556 (originally from r7rs).
The tests currently fail because errors and raised objects are
treated in the same way.

* Use different tags for raised objects and raised errors

The behaviour for raising an error (error message irritants) and
objects (raise object) are different in r7rs. So tag error objects
differently, and adjust the raised object handling to handle
the raised object instead of a list containing the raised object.

This should resolve issue #556.

* runtime: use the correct string length for comparison

Fix for the pull request adressing issue #556.

* runtime: distinguish exceptions and errors in default handler

* repl: use error-object? to decide whether an error or an exception was raised

This makes error messages a bit more informative.  Also, if error objects become
a distinct type, then the repl implementation will continue to be correct. The
(deleted) second cond clause seemed to be bit redundant - I am not sure what the
original intent was.

* tests/base.scm: revert accidental deletion of else clause

* Display exceptions as errors for consistency

.github/workflows/c-api-docs.yml

@@ -21,7 +21,7 @@ jobs:
             
     - name: upload deb
       if: matrix.arch == '64'
-      uses: actions/upload-artifact@v1
+      uses: actions/upload-artifact@v4
       with:
         name: cyclone-scheme docs
         path: html.tar.bz2

.github/workflows/c-runtime-unit-tests.yml

@@ -0,0 +1,27 @@
+name: C Runtime Unit Tests
+
+#on: [create]
+on: [push]
+
+jobs:
+  build:
+
+    runs-on: ubuntu-latest
+    
+    strategy:    
+      matrix:
+        arch: [64]
+    
+    steps:
+    # Install dependencies
+    - name: Install libck
+      run: sudo apt-get install libck-dev    
+    #- name: Install Cyclone
+    #  run: |
+    #    wget https://github.com/cyclone-scheme/binary-releases/raw/master/ubuntu-18.04-lts/cyclone-scheme_0.30.0_amd64.deb 
+    #    sudo apt install ./cyclone-scheme_0.30.0_amd64.deb
+    - uses: actions/checkout@v1
+
+    # Execute runtime library unit tests
+    - name: make test-lib
+      run: make libcyclone.a && make test-lib && ./test-lib

.github/workflows/ci.yml

@@ -0,0 +1,22 @@
+name: Ubuntu Linux Build
+
+on: [push]
+
+jobs:
+  build:
+
+    runs-on: ubuntu-latest
+    
+    strategy:    
+      matrix:
+        arch: [32, 64]
+    
+    steps:
+    - uses: actions/checkout@v1
+    - name: Install deps
+      run: sudo apt-get install indent
+    - name: Install ck
+      run: sudo apt-get install libck-dev
+    - name: make runtime
+      run: make libcyclone.a
+            

.github/workflows/formatting.yml

@@ -16,5 +16,6 @@ jobs:
     - name: Install deps
       run: sudo apt-get install -y indent
     - name: formatting
-      run: make test-format
+      run: |
+        make test-format 
             

CHANGELOG.md

@@ -1,5 +1,21 @@
 # Changelog
 
+## 0.37.0 - TBD
+
+Bug Fixes
+
+- Yorick Hardy fixed the runtime to return the appropriate types of objects to exception handlers.
+- Yorick Hardy modified the runtime to allow `thread-terminate!` to take a thread object as an argument, per SRFI 18.
+- @nmeum fixed `open_memstream`/`fmemopen` feature detection with GCC >= 14.
+- Fixed a bug in `apply` where an error may be raised when processing quoted sub-expressions. For example the following would throw an error: `(apply cons '(5 (1 2)))`. Thanks to @srgx for the bug report!
+- Fixed a beta expansion optimization bug where code such as the following would cause the compiler to hang. Thanks to Yorick Hardy for the bug report:
+
+      (define (compile-forever x) x (compile-forever x))
+
+- Added a fix from Yorick Hardy to define `*ai-v4mapped*` to zero on platforms where `AI_V4MAPPED` is undefined.
+- Updated `sqrt` to properly handle complex results given non-complex input. EG: `(sqrt -1) ==> 1i`. And updated the parser to properly handle `+i` and `-i`. Thanks to Christopher Hebert for the bug reports!
+- Updated `cond-expand` to raise an error if no clauses match, instead of returning `#t`.
+
 ## 0.36.0 - February 14, 2024
 
 Features

Makefile

@@ -131,7 +131,10 @@ tags :
 	ctags -R *
 
 format : gc.c runtime.c ffi.c hashset.c mstreams.c ck-polyfill.c ck-polyfill.h $(HEADER_DIR)/*.h
-	$(FORMAT_CMD) $(HEADER_DIR)/*.h
+	$(FORMAT_CMD) $(HEADER_DIR)/hashset.h
+	$(FORMAT_CMD) $(HEADER_DIR)/runtime.h
+	$(FORMAT_CMD) $(HEADER_DIR)/runtime-main.h
+	$(FORMAT_CMD) $(HEADER_DIR)/types.h
 	$(FORMAT_CMD) ck-polyfill.c
 	$(FORMAT_CMD) ck-polyfill.h
 	$(FORMAT_CMD) ffi.c
@@ -141,7 +144,17 @@ format : gc.c runtime.c ffi.c hashset.c mstreams.c ck-polyfill.c ck-polyfill.h $
 	$(FORMAT_CMD) runtime.c
 
 test-format :
+	./scripts/check-c-formatting.sh $(HEADER_DIR)/hashset.h
+	./scripts/check-c-formatting.sh $(HEADER_DIR)/runtime.h
+	./scripts/check-c-formatting.sh $(HEADER_DIR)/runtime-main.h
+	./scripts/check-c-formatting.sh $(HEADER_DIR)/types.h
+#	./scripts/check-c-formatting.sh ffi.c
+#	./scripts/check-c-formatting.sh gc.c
 	./scripts/check-c-formatting.sh hashset.c
+#	./scripts/check-c-formatting.sh mstreams.c
+#	./scripts/check-c-formatting.sh runtime.c
+#	./scripts/check-c-formatting.sh ck-polyfill.c
+#	./scripts/check-c-formatting.sh ck-polyfill.h
 
 # This is a test directive used to test changes to a SLD file
 # EG: make sld SLDPATH=scheme/cyclone SLD=macros
@@ -342,3 +355,7 @@ install-bin : cyclone icyc
 	$(MKDIR) $(DESTDIR)$(BINDIR)
 	$(INSTALL) -m0755 cyclone $(DESTDIR)$(BINDIR)/
 	$(INSTALL) -m0755 icyc $(DESTDIR)$(BINDIR)/
+
+# TODO: is this linking in local lcyclone or the system one????
+test-lib: test-lib.c
+	$(CCOMP) -g test-lib.c -o test-lib -L . $(LIBS)

Makefile.config

@@ -91,8 +91,9 @@ DESTDIR   ?=
 
 # Automatically detect platform-specific flags, instead of using autoconf
 #CYC_PLATFORM_HAS_MEMSTREAM ?= 1
-CYC_PLATFORM_HAS_MEMSTREAM := $(shell echo "main(){char *buf; int len; open_memstream(&buf, &len);}" | $(CC) -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
-CYC_PLATFORM_HAS_FMEMOPEN := $(shell echo "main(){char *buf; fmemopen(&buf, 0, \"r\");}" | $(CC) -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
+HASH := \# # Needed for compatibility with GNU Make < 4.3 <https://lists.gnu.org/archive/html/info-gnu/2020-01/msg00004.html>
+CYC_PLATFORM_HAS_MEMSTREAM := $(shell printf "$(HASH)include <stdio.h>\n%s\n" "int main(void){char *buf; size_t len; open_memstream(&buf, &len); return 0;}" | $(CC) -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
+CYC_PLATFORM_HAS_FMEMOPEN := $(shell printf "$(HASH)include <stdio.h>\n%s\n" "int main(void){char *buf; fmemopen(&buf, 0, \"r\"); return 0;}" | $(CC) -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
 
 # code from chibi's makefile to detect platform
 ifndef PLATFORM

docs/Release-Checklist.md

@@ -15,3 +15,8 @@ Steps for making a release of Cyclone:
 - Update release on Homebrew (automated)
 - Update release on Dockerhub (push to bitbucket)
 - Upload new binary from cyclone-bootstrap release build to the cyclone-scheme "packages" repo
+- Update WASM hosted Cyclone
+  - Trigger CI action on the WASM repo to recompile the WASM binary: https://github.com/cyclone-scheme/wasm-terminal
+  - Download the generated `.zip` artifact
+  - Extract `terminal.js` and `terminal.wasm` and copy to the `_site` directory in the repo to update the build
+  - Optionally update year in the `terminal.html` file

docs/api/srfi/18.md

@@ -92,9 +92,9 @@ The current thread exits the running state as if its quantum had expired.
 
 # thread-terminate!
 
-    (thread-terminate!)
+    (thread-terminate! thread)
 
-Immediately abort the current thread.
+Immediately abort the given thread.
 
 # thread-join!
 

gc.c

@@ -55,6 +55,7 @@ static unsigned char gc_color_purple = 1;       // There are many "shades" of pu
 
 static int gc_status_col = STATUS_SYNC1;
 static int gc_stage = STAGE_RESTING;
+static int gc_threads_merged = 0;
 
 // Does not need sync, only used by collector thread
 static void **mark_stack = NULL;
@@ -1901,6 +1902,38 @@ void gc_mut_update(gc_thread_data * thd, object old_obj, object value)
   }
 }
 
+static void gc_sweep_primordial_thread_heap()
+{
+  int heap_type, must_free;
+  gc_heap *h, *prev, *next, *sweep;
+  pthread_mutex_lock(&(primordial_thread->lock));
+  for (heap_type = 0; heap_type < NUM_HEAP_TYPES; heap_type++) {
+    prev = primordial_thread->heap->heap[heap_type];
+    h = prev->next;
+    while (h != NULL) {
+      next = h->next;
+      must_free = 0;
+      if (h->is_unswept) {
+        if (h->type <= LAST_FIXED_SIZE_HEAP_TYPE) {
+          sweep = gc_sweep_fixed_size(h, primordial_thread);
+        } else {
+          sweep = gc_sweep(h, primordial_thread);
+        }
+        must_free = (sweep == NULL);
+      } else {
+        must_free = gc_is_heap_empty(h);
+      }
+      if (must_free) {
+        gc_heap_free(h, prev);
+      } else {
+        prev = h;
+      }
+      h = next;
+    }
+  }
+  pthread_mutex_unlock(&(primordial_thread->lock));
+}
+
 /**
  * @brief Called by a mutator to cooperate with the collector thread
  * @param thd Mutator's thread data
@@ -1911,11 +1944,23 @@ void gc_mut_update(gc_thread_data * thd, object old_obj, object value)
  */
 void gc_mut_cooperate(gc_thread_data * thd, int buf_len)
 {
-  int i, status_c, status_m;
+  int i, status_c, status_m, stage, merged;
 #if GC_DEBUG_VERBOSE
   int debug_print = 0;
 #endif
 
+  // Since terminated threads' heap pages are merged into
+  // the primordial thread's heap, it may be that a sweep
+  // for the primordeal thread is never triggered even though
+  // the heep keeps growing. Perform a sweep here if necessary.
+  stage = ck_pr_load_int(&gc_stage);
+  merged = ck_pr_load_int(&gc_threads_merged);
+  if ((thd == primordial_thread) && (merged == 1)
+      && ((stage == STAGE_SWEEPING) || (stage == STAGE_RESTING))) {
+    gc_sweep_primordial_thread_heap();
+    ck_pr_cas_int(&gc_threads_merged, 1, 0);
+  }
+
   // Handle any pending marks from write barrier
   gc_sum_pending_writes(thd, 0);
 
@@ -2739,10 +2784,28 @@ void gc_thread_data_free(gc_thread_data * thd)
  *
  * This function assumes appropriate locks are already held.
  */
-void gc_heap_merge(gc_heap * hdest, gc_heap * hsrc)
+int gc_heap_merge(gc_heap * hdest, gc_heap * hsrc)
 {
+  int freed = 0;
   gc_heap *last = gc_heap_last(hdest);
+  gc_heap *cur = hsrc, *prev = last, *next;
   last->next = hsrc;
+  // free any empty heaps and convert remaining heaps
+  // to free list so that they can be swept
+  while (cur != NULL) {
+    cur->is_unswept = 1;
+    next = cur->next;
+    if (gc_is_heap_empty(cur)) {
+      freed += cur->size;
+      gc_heap_free(cur, prev);
+    } else {
+      gc_convert_heap_page_to_free_list(cur, primordial_thread);
+      ck_pr_cas_int(&gc_threads_merged, 0, 1);
+      prev = cur;
+    }
+    cur = next;
+  }
+  return freed;
 }
 
 /**
@@ -2755,15 +2818,47 @@ void gc_heap_merge(gc_heap * hdest, gc_heap * hsrc)
 void gc_merge_all_heaps(gc_thread_data * dest, gc_thread_data * src)
 {
   gc_heap *hdest, *hsrc;
-  int heap_type;
+  int freed, heap_type, i;
+  pair_type *context = NULL;
+  vector_type *v = src->scm_thread_obj;
+
+  // The following objects are part of the thread context and should
+  // be stored on the primordial thread's heap. Make this explicit by
+  // including it in the thread object.
+  if (src->gc_num_args > 0) {
+    for (i = src->gc_num_args - 1; i >= 0; --i) {
+      context = gc_alloc_pair(dest, (src->gc_args)[i], context);
+    }
+  }
+  if (src->gc_cont != NULL && is_object_type(src->gc_cont)) {
+    context = gc_alloc_pair(dest, src->gc_cont, context);
+  }
+  if (src->exception_handler_stack != NULL) {
+    context = gc_alloc_pair(dest, src->exception_handler_stack, context);
+  }
+  if (src->param_objs != NULL) {
+    context = gc_alloc_pair(dest, src->param_objs, context);
+  }
+
+  if (context != NULL) {
+    gc_mark_black(context);
+    v->elements[8] = context;
+  }
 
   for (heap_type = 0; heap_type < NUM_HEAP_TYPES; heap_type++) {
     hdest = dest->heap->heap[heap_type];
     hsrc = src->heap->heap[heap_type];
+    if (!hdest) {
+      fprintf(stderr,
+              "WARNING !!!!! merging heap type %d does not happen: hdest = %p hsrc = %p size = %d\n",
+              heap_type, hdest, hsrc, hsrc->size);
+      fflush(stderr);
+    }
     if (hdest && hsrc) {
-      gc_heap_merge(hdest, hsrc);
+      freed = gc_heap_merge(hdest, hsrc);
       ck_pr_add_ptr(&(dest->cached_heap_total_sizes[heap_type]),
-                    ck_pr_load_ptr(&(src->cached_heap_total_sizes[heap_type])));
+                    ck_pr_load_ptr(&(src->cached_heap_total_sizes[heap_type])) -
+                    freed);
       ck_pr_add_ptr(&(dest->cached_heap_free_sizes[heap_type]),
                     ck_pr_load_ptr(&(src->cached_heap_free_sizes[heap_type])));
     }

guix/cyclone.scm

@@ -0,0 +1,87 @@
+;; cyclone.scm
+(use-modules
+ (gnu packages)
+ (gnu packages multiprecision)
+ ((guix licenses)
+  #:select (gpl2 gpl2+ lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3+ asl2.0
+                 bsd-0 bsd-3 cc-by-sa4.0 non-copyleft expat
+                 public-domain))
+ (guix gexp)
+ (guix packages)
+ (guix download)
+ (guix git-download)
+ (guix utils)
+ (guix build-system gnu)
+ (gnu packages c))
+
+(define-public cyclone
+  (package
+    (name "cyclone")
+    (version "0.36.0")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/justinethier/cyclone-bootstrap")
+                    (commit (string-append "v" version))))
+              (sha256
+               (base32
+                "0fv0mnrn5shbx77383f4mbkvc4i9yyj1bjm3dfyhipnaqapbhqpi"))
+              (file-name (git-file-name name version))))
+    (build-system gnu-build-system)
+    (arguments
+     (list
+      #:test-target "test"
+      #:make-flags #~(list (string-append
+                            "CC=" #$(this-package-input "gcc-toolchain")
+                            "/bin/gcc")
+                           (string-append "PREFIX=" #$output)
+                           (string-append "COMP_INCDIRS=-I$(PREFIX)/include -I"
+                                          #$(this-package-input "gcc-toolchain")
+                                          "/include")
+                           (string-append
+                            "COMP_LIBDIRS=-L$(PREFIX)/lib "
+                            "-Wl,-rpath=" #$(this-package-input "ck") "/lib "
+                            "-L" #$(this-package-input "ck") "/lib "
+                            "-Wl,-rpath=" #$(this-package-input "libtommath")
+                            "/lib "
+                            "-L" #$(this-package-input "libtommath") "/lib "
+                            "-Wl,-rpath="
+                            #$(this-package-input "gcc-toolchain") "/lib "
+                            "-L" #$(this-package-input "gcc-toolchain")
+                            "/lib"))
+      #:phases #~(modify-phases %standard-phases
+                   (delete 'configure) ; no configure script
+                   (add-before 'build 'replace-cyclonebn
+                     (lambda* (#:key outputs #:allow-other-keys)
+                       (substitute* "Makefile"
+                         (("-lcyclonebn")
+                          "-ltommath")
+                         (("^[$][(]CYC_BN_LIB[)] :")
+                          "dont-build-cyclonebn :")
+                         (("^	[$][(]INSTALL[)] .* [$][(]CYC_BN_LIB[)].*$")
+                          "#dont-install-cyclonebn\n")
+                         (("[$][(]CYC_BN_LIB[)]")
+                          ""))
+                       (substitute* "Makefile.config"
+                         (("-lcyclonebn")
+                          "-ltommath"))))
+                   (add-after 'install 'wrap
+                     (lambda _
+                       (wrap-program (string-append #$output "/bin/cyclone")
+                         `("LIBRARY_PATH" ":" prefix
+                           ,(list (string-append
+                                   #$(this-package-input "gcc-toolchain")
+                                   "/lib")))))))))
+    (inputs (list ck libtommath (module-ref (resolve-interface
+                                             '(gnu packages commencement))
+                                            'gcc-toolchain)))
+    (home-page "https://justinethier.github.io/cyclone/")
+    (synopsis "R7RS Scheme to C compiler")
+    (description
+     "Cyclone Scheme is a R7RS Scheme-to-C compiler that uses a variant of
+Cheney on the MTA to implement full tail recursion, continuations, and
+generational garbage collection.  It also includes the Winds package manager
+for installing Cyclone libraries.")
+    (license expat)))
+
+cyclone

include/cyclone/bignum.h

@@ -766,8 +766,7 @@ extern "C" {
 
    MP_DEPRECATED(mp_ubin_size) int mp_unsigned_bin_size(const mp_int *
                                                         a) MP_WUR;
-   MP_DEPRECATED(mp_from_ubin) mp_err mp_read_unsigned_bin(mp_int * a,
-                                                           const unsigned char
+   MP_DEPRECATED(mp_from_ubin) mp_err mp_read_unsigned_bin(mp_int * a, const unsigned char
                                                            *b, int c) MP_WUR;
    MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin(const mp_int * a,
                                                        unsigned char *b) MP_WUR;

include/cyclone/types.h

@@ -385,7 +385,7 @@ int gc_is_mutator_new(gc_thread_data * thd);
 void gc_sleep_ms(int ms);
 gc_heap *gc_heap_create(int heap_type, size_t size, gc_thread_data * thd);
 gc_heap *gc_heap_free(gc_heap * page, gc_heap * prev_page);
-void gc_heap_merge(gc_heap * hdest, gc_heap * hsrc);
+int gc_heap_merge(gc_heap * hdest, gc_heap * hsrc);
 void gc_merge_all_heaps(gc_thread_data * dest, gc_thread_data * src);
 void gc_print_stats(gc_heap * h);
 gc_heap *gc_grow_heap(gc_heap * h, size_t size, gc_thread_data * thd);
@@ -1261,6 +1261,9 @@ typedef pair_type *pair;
   n->pair_car = a; \
   n->pair_cdr = d;
 
+/** Create a new pair in the thread's heap */
+void *gc_alloc_pair(gc_thread_data * data, object head, object tail);
+
 /**
  * Set members of the given pair 
  * @param n - Pointer to a pair object

runtime.c

@@ -8,6 +8,7 @@
  * This file contains the C runtime used by compiled programs.
  */
 
+#include <assert.h>
 #include <ck_hs.h>
 #include <ck_ht.h>
 #include <ck_pr.h>
@@ -29,6 +30,8 @@ static uint32_t Cyc_utf8_decode(uint32_t * state, uint32_t * codep,
 static int Cyc_utf8_count_code_points_and_bytes(uint8_t * s,
                                                 char_type * codepoint,
                                                 int *cpts, int *bytes);
+void gc_start_major_collection(gc_thread_data * thd);
+static void Cyc_cancel_thread(gc_thread_data * thd);
 
 /* Error checking section - type mismatch, num args, etc */
 /* Type names to use for error messages */
@@ -211,6 +214,8 @@ const object Cyc_RECORD_MARKER = &__RECORD;
 static ck_hs_t lib_table;
 static ck_hs_t symbol_table;
 static int symbol_table_initial_size = 4096;
+static int cyclone_thread_key_create = 1;
+static pthread_key_t cyclone_thread_key;
 static pthread_mutex_t symbol_table_lock;
 
 char **env_variables = NULL;
@@ -701,11 +706,13 @@ object Cyc_default_exception_handler(void *data, object _, int argc,
 {
   object err = args[0];
   int is_msg = 1;
-  fprintf(stderr, "Error: ");
 
-  if ((err == NULL) || is_value_type(err) || type_of(err) != pair_tag) {
+  if ((err == NULL) || is_value_type(err) || type_of(err) != pair_tag || type_of(car(err)) != symbol_tag) {
+    fprintf(stderr, "Error: ");
     Cyc_display(data, err, stderr);
   } else {
+    if (strncmp(((symbol) car(err))->desc, "error", 5) == 0) {
+      fprintf(stderr, "Error: ");
       // Error is list of form (type arg1 ... argn)
       err = cdr(err);             // skip type field
       for (; (err != NULL); err = cdr(err)) {     // output with no enclosing parens
@@ -720,6 +727,10 @@ object Cyc_default_exception_handler(void *data, object _, int argc,
           fprintf(stderr, " ");
         }
       }
+    } else {
+      fprintf(stderr, "Error: ");
+      Cyc_display(data, cdr(err), stderr);
+    }
   }
 
   fprintf(stderr, "\nCall history, most recent first:\n");
@@ -5360,7 +5371,7 @@ void _Cyc_91end_91thread_67(void *data, object clo, int argc, object * args)
   vector_type *v = d->scm_thread_obj;
   v->elements[7] = args[0];     // Store thread result
 
-  Cyc_end_thread((gc_thread_data *) data);
+  Cyc_end_thread(d);
   object cont = args[0];
   return_closcall1(data, cont, boolean_f);
 }
@@ -6412,6 +6423,7 @@ int gc_minor(void *data, object low_limit, object high_limit, closure cont,
     exit(1);
   }
 
+  if (cont != NULL) {
     gc_move2heap(cont);
     ((gc_thread_data *) data)->gc_cont = cont;
     ((gc_thread_data *) data)->gc_num_args = num_args;
@@ -6420,7 +6432,7 @@ int gc_minor(void *data, object low_limit, object high_limit, closure cont,
       gc_move2heap(args[i]);
       ((gc_thread_data *) data)->gc_args[i] = args[i];
     }
-
+  }
   // Transport exception stack
   gc_move2heap(((gc_thread_data *) data)->exception_handler_stack);
   gc_move2heap(((gc_thread_data *) data)->param_objs);
@@ -6557,8 +6569,13 @@ void GC(void *data, closure cont, object * args, int num_args)
 #ifdef CYC_HIGH_RES_TIMERS
   hrt_log_delta("minor gc", tstamp);
 #endif
+  // if this thread has a continuation (i.e. it is not cancelled)
+  // then we can continue after the minor GC, otherwise we return
+  // to the destructor which initiated the minor GC.
+  if (cont != NULL) {
     // Let it all go, Neo...
     longjmp(*(((gc_thread_data *) data)->jmp_start), 1);
+  }
 }
 
 /**
@@ -6598,8 +6615,7 @@ void Cyc_make_shared_object(void *data, object k, object obj)
   case port_tag:
   case c_opaque_tag:
   case complex_num_tag:{
-      object hp =
-          gc_alloc(heap, gc_allocated_bytes(obj, NULL, NULL), obj, thd,
+      object hp = gc_alloc(heap, gc_allocated_bytes(obj, NULL, NULL), obj, thd,
                            heap_grown);
       return_closcall1(data, k, hp);
     }
@@ -6785,7 +6801,8 @@ static primitive_type Cyc_91installation_91dir_primitive =
     { {0}, primitive_tag, &_Cyc_91installation_91dir, "Cyc-installation-dir" };
 static primitive_type Cyc_91compilation_91environment_primitive =
     { {0}, primitive_tag, &_Cyc_91compilation_91environment,
-    "Cyc-compilation-environment" };
+"Cyc-compilation-environment"
+};
 static primitive_type command_91line_91arguments_primitive =
     { {0}, primitive_tag, &_command_91line_91arguments, "command-line-arguments"
 };
@@ -6866,10 +6883,12 @@ static primitive_type open_91output_91file_primitive =
     { {0}, primitive_tag, &_open_91output_91file, "open-output-file" };
 static primitive_type open_91binary_91input_91file_primitive =
     { {0}, primitive_tag, &_open_91binary_91input_91file,
-    "open-binary-input-file" };
+"open-binary-input-file"
+};
 static primitive_type open_91binary_91output_91file_primitive =
     { {0}, primitive_tag, &_open_91binary_91output_91file,
-    "open-binary-output-file" };
+"open-binary-output-file"
+};
 static primitive_type close_91port_primitive =
     { {0}, primitive_tag, &_close_91port, "close-port" };
 static primitive_type close_91input_91port_primitive =
@@ -6878,7 +6897,8 @@ static primitive_type close_91output_91port_primitive =
     { {0}, primitive_tag, &_close_91output_91port, "close-output-port" };
 static primitive_type Cyc_91flush_91output_91port_primitive =
     { {0}, primitive_tag, &_Cyc_91flush_91output_91port,
-    "Cyc-flush-output-port" };
+"Cyc-flush-output-port"
+};
 static primitive_type file_91exists_127_primitive =
     { {0}, primitive_tag, &_file_91exists_127, "file-exists?" };
 static primitive_type delete_91file_primitive =
@@ -7125,6 +7145,12 @@ void *Cyc_init_thread(object thread_and_thunk, int argc, object * args)
   gc_add_mutator(thd);
   ck_pr_cas_int((int *)&(thd->thread_state), CYC_THREAD_STATE_NEW,
                 CYC_THREAD_STATE_RUNNABLE);
+  if (ck_pr_cas_int(&cyclone_thread_key_create, 1, 0)) {
+    int r = pthread_key_create(&cyclone_thread_key,
+                               (void (*)(void *))Cyc_cancel_thread);
+    assert(r == 0);
+  }
+  pthread_setspecific(cyclone_thread_key, thd);
   Cyc_start_trampoline(thd);
   return NULL;
 }
@@ -7181,9 +7207,25 @@ void Cyc_exit_thread(void *data, object _, int argc, object * args)
   gc_remove_mutator(thd);
   ck_pr_cas_int((int *)&(thd->thread_state), CYC_THREAD_STATE_RUNNABLE,
                 CYC_THREAD_STATE_TERMINATED);
+  gc_start_major_collection(thd);
   pthread_exit(NULL);
 }
 
+/**
+ * Cancel a thread
+ */
+static void Cyc_cancel_thread(gc_thread_data * thd)
+{
+  // do a minor GC without a continuation, so that we return
+  // here without performing a longjmp
+  GC(thd, (closure) NULL, (object *) NULL, 0);
+  if (gc_is_mutator_active(thd)) {
+    gc_remove_mutator(thd);
+  }
+  ck_pr_cas_int((int *)&(thd->thread_state), CYC_THREAD_STATE_RUNNABLE,
+                CYC_THREAD_STATE_TERMINATED);
+}
+
 /**
  * @brief Accept a number of seconds to sleep according to SRFI-18
  */
@@ -7536,8 +7578,8 @@ static void _read_add_to_tok_buf(port_type * p, char c)
  */
 static int _read_is_numeric(const char *tok, int len)
 {
-  return (len &&
-          ((isdigit(tok[0])) ||
+  return (len && ((isdigit(tok[0])) || (((len == 2) && tok[1] == 'i')
+                                        && (tok[0] == '-' || tok[0] == '+')) ||
                   ((len > 1) && tok[0] == '.' && isdigit(tok[1])) ||
                   ((len > 1) && (tok[1] == '.' || isdigit(tok[1]))
                    && (tok[0] == '-' || tok[0] == '+'))));
@@ -7931,9 +7973,6 @@ static void _read_return_number(void *data, port_type * p, int base, int exact)
  */
 static void _read_return_complex_number(void *data, port_type * p, int len)
 {
-//      TODO: return complex num, see _read_return_number for possible template
-//      probably want to have that function extract/identify the real/imaginary components.
-//      can just scan the buffer and read out start/end index of each number.
   int i;
   make_empty_vector(vec);
   make_string(str, p->tok_buf);
@@ -8767,7 +8806,7 @@ int num2ratio(double x, double *numerator, double *denominator)
 
 double round_to_nearest_even(double x)
 {
- return x-remainder(x,1.0);
+  return x - remainder(x, 1.0);
 }
 
 /**

scheme/base.sld

@@ -407,7 +407,7 @@
                   (else (error "cond-expand: bad feature" x)))
                 (memq x (features))))
           (let expand ((ls (cdr expr)))
-            (cond ((null? ls))  ; (error "cond-expand: no expansions" expr)
+            (cond ((null? ls)  (error "cond-expand: no expansions" expr))
                   ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls)))
                   ((eq? 'else (caar ls)) ;(identifier->symbol (caar ls)))
                    (if (pair? (cdr ls))
@@ -1251,13 +1251,16 @@
     (define error-object-message car)
     (define error-object-irritants cdr)
     (define (error msg . args)
-      (raise (cons msg args)))
+      (raise-error (cons msg args)))
     (define (raise obj)
       ((Cyc-current-exception-handler) 
-        (cons 'raised (if (pair? obj) obj (list obj)))))
+        (cons 'raised obj)))
     (define (raise-continuable obj)
       ((Cyc-current-exception-handler) 
-        (cons 'continuable (if (pair? obj) obj (list obj)))))
+        (cons 'continuable obj)))
+    (define (raise-error obj)
+      ((Cyc-current-exception-handler) 
+        (cons 'error obj)))
     ;; A simpler exception handler based on the one from Bigloo:
     ;; https://www-sop.inria.fr/indes/fp/Bigloo/doc/bigloo-17.html#g20889
     ;(define (with-handler handler body)
@@ -1437,10 +1440,10 @@
       (error "exact non-negative integer required" k))
     (let* ((s (if (bignum? k)
                   (bignum-sqrt k)
-                  (exact (truncate (sqrt k)))))
+                  (exact (truncate (_sqrt k)))))
            (r (- k (* s s))))
       (values s r)))
-  (define-c sqrt
+  (define-c _sqrt
     "(void *data, int argc, closure _, object k, object z)"
     " return_inexact_double_op(data, k, sqrt, z);"
     "(void *data, object ptr, object z)"

scheme/cyclone/common.sld

@@ -18,7 +18,7 @@
     memloc
   )
   (begin
-(define *version-number* "0.36.0")
+(define *version-number* "0.37.0")
 (define *version-name* "")
 (define *version* (string-append *version-number* " " *version-name* ""))
 
@@ -32,7 +32,7 @@
        @@     @@     Cyclone Scheme->C compiler
       ,@             http://justinethier.github.io/cyclone/
       '@        
-      .@             (c) 2014-2024 Justin Ethier
+      .@             (c) 2014-2025 Justin Ethier
        @@     #@     Version " *version* "
        `@@@#@@@.
         #@@@@@   

scheme/cyclone/cps-opt-analyze-call-graph.scm

@@ -20,7 +20,8 @@
             (srfi 2)
             (srfi 69)
             )
-    ))
+    )
+  (else #f))
 
 ;; symbol -> hash-table -> boolean
 ;; Is it OK to inline code replacing ref, based on call graph data from lookup table?
@@ -261,4 +262,5 @@
     ;  (ast:ast->pp-sexp
     ;    (opt:local-var-reduction (ast:sexp->ast sexp)))
     ;)
-))
+)
+(else #f))

scheme/cyclone/cps-opt-local-var-redux.scm

@@ -14,7 +14,9 @@
             (scheme cyclone ast) 
             (scheme cyclone primitives)
             (scheme cyclone util) 
-            (scheme cyclone pretty-print))))
+            (scheme cyclone pretty-print)))
+  (else
+    #f))
 
 ;; Local variable reduction:
 ;; Reduce given sexp by replacing certain lambda calls with a let containing
@@ -434,4 +436,5 @@
       (ast:ast->pp-sexp
         (opt:local-var-reduction (ast:sexp->ast sexp)))
     )
-    ))
+    )
+  (else #f))

scheme/cyclone/cps-opt-memoize-pure-fncs.scm

@@ -18,9 +18,9 @@
             (scheme cyclone util) 
             (scheme cyclone pretty-print)
             (srfi 2)
-            (srfi 69)
-            )
-    ))
+            (srfi 69)))
+  (else
+    #f))
 
 ;; Predicate to determine if a function can be memoized
 ;; var - symbol - global name of the function
@@ -371,4 +371,5 @@
 ;;    ;  (ast:ast->pp-sexp
 ;;    ;    (opt:local-var-reduction (ast:sexp->ast sexp)))
 ;;    ;)
-))
+)
+(else #f))

scheme/cyclone/cps-optimizations.sld

@@ -1665,7 +1665,7 @@
 
     ;; Full beta expansion phase, make a pass over all of the program's AST
     (define (opt:beta-expand exp)
-;(write `(DEBUG opt:beta-expand ,exp)) (newline)
+      ;(trace:info `(opt:beta-expand ,exp)) (flush-output-port)
       (cond
        ((ast:lambda? exp)
         (ast:%make-lambda
@@ -1694,6 +1694,7 @@
        (else exp)))
 
     (define (analyze-cps exp)
+      ;(trace:info `(analyze-cps ,exp))
       (analyze:find-named-lets exp)
       (analyze:find-direct-recursive-calls exp)
       (analyze:find-recursive-calls exp)
@@ -2230,11 +2231,17 @@
       (scan (if->then exp) def-sym)
       (scan (if->else exp) def-sym))
      ((app? exp)
-      (when (equal? (car exp) def-sym)
+      ;(trace:info `(analyze:find-recursive-calls scan app ,exp))
+      (cond
+        ((equal? (car exp) def-sym)
          (trace:info `("recursive call" ,exp))
          (with-var! def-sym (lambda (var)
-          (adbv:set-self-rec-call! var #t)))
-        ))
+           (adbv:set-self-rec-call! var #t))))
+        (else
+          (for-each
+            (lambda (e)
+              (scan e def-sym))
+            exp))))
      (else #f)))
 
   ;; TODO: probably not good enough, what about recursive functions that are not top-level??

scheme/cyclone/pass-validate-syntax.scm

@@ -14,7 +14,8 @@
       (scheme base)
       (scheme read)
       (scheme cyclone pretty-print)
-      (scheme cyclone util))))
+      (scheme cyclone util)))
+   (else #f))
 ;;
 ;; TODO: call this from cyclone.scm after it works, probably after "resolve macros"
 
@@ -59,7 +60,9 @@
   (define (search exp vars)
     (cond-expand
       (program
-        (pretty-print `(search ,exp ,vars))(newline))) ;; Debugging
+        (pretty-print `(search ,exp ,vars))(newline)) ;; Debugging
+      (else
+        #f))
     (cond
       ;((ast:lambda? exp) 'TODO)
       ((const? exp) #f)
@@ -111,4 +114,5 @@
     ;(if 1 2 3 4)
     
      (let ((sexp (read-all (open-input-file "validation.scm"))))
-      (validate-keyword-syntax sexp))))
+      (validate-keyword-syntax sexp)))
+  (else #f))

scheme/eval.sld

@@ -89,17 +89,26 @@
       ((analyze exp *global-environment* rename-env '()) *global-environment*)
       ((analyze exp (car env) rename-env '()) (car env))))
 
+;; Called from the C runtime to support apply
 (define (eval-from-c exp . _env)
   (let ((env (if (null? _env) *global-environment* (car _env))))
     (eval (wrapc exp) env)))
 
-;; Expressions received from C code are already evaluated, but sometimes too much so.
-;; Try to wrap 
+;; Helper function for eval-from-c
+;; 
+;; Expressions received from C code are already evaluated, 
+;; however any quoted expressions will have the quotes
+;; stripped off. This is a problem for expressions that
+;; aren't self evaluating - like (1 2) - so we re-quote
+;; the expressions here so a subsequent eval will work.
+;;
 (define (wrapc exp)
   (cond 
     ((application? exp)
      (cond
-       ((compound-procedure? (car exp))
+       ((or (primitive-procedure? (car exp)) 
+            (compound-procedure? (car exp))
+            (procedure? (car exp)))
         (cons 
           (car exp)
           (map 

scheme/inexact.sld

@@ -69,7 +69,6 @@
             (/ (c-log z1) (c-log z2*)))))
     (define-inexact-op c-log "log"   "clog")
     (define-inexact-op exp   "exp"   "cexp")
-    (define-inexact-op sqrt  "sqrt"  "csqrt")
     (define-inexact-op sin   "sin"   "csin")
     (define-inexact-op cos   "cos"   "ccos")
     (define-inexact-op tan   "tan"   "ctan")
@@ -93,4 +92,58 @@
                         (* (if (eqv? y -0.0) -1 1)
                            (if (eqv? x -0.0) 3.141592653589793 x))
                         (atan1 (/ y x))))))))
+
+ (define-c
+   sqrt
+   "(void *data, int argc, closure _, object k, object z)"
+   " double complex result;
+     Cyc_check_num(data, z);
+     if (obj_is_int(z)) {
+       result = csqrt(obj_obj2int(z));
+     } else if (type_of(z) == integer_tag) {
+       result = csqrt(((integer_type *)z)->value);
+     } else if (type_of(z) == bignum_tag) {
+       result = csqrt(mp_get_double(&bignum_value(z)));
+     } else if (type_of(z) == complex_num_tag) {
+       result = csqrt(complex_num_value(z));
+     } else {
+       result = csqrt(((double_type *)z)->value);
+     }
+   
+     if (cimag(result) == 0.0) {
+       if (obj_is_int(z) && creal(result) == round(creal(result))) {
+         return_closcall1(data, k, obj_int2obj(creal(result)));
+       }
+       make_double(d, creal(result));
+       return_closcall1(data, k, &d);
+     } else {
+       complex_num_type cn;
+       assign_complex_num((&cn), result);
+       return_closcall1(data, k, &cn);
+     } "
+   "(void *data, object ptr, object z)"
+   " double complex result;
+     Cyc_check_num(data, z);
+     if (obj_is_int(z)) {
+       result = csqrt(obj_obj2int(z));
+     } else if (type_of(z) == integer_tag) {
+       result = csqrt(((integer_type *)z)->value);
+     } else if (type_of(z) == bignum_tag) {
+       result = csqrt(mp_get_double(&bignum_value(z)));
+     } else if (type_of(z) == complex_num_tag) {
+       result = csqrt(complex_num_value(z));
+     } else {
+       result = csqrt(((double_type *)z)->value);
+     }
+  
+     if (cimag(result) == 0.0) {
+       if (obj_is_int(z) && creal(result) == round(creal(result))) {
+         return obj_int2obj(creal(result));
+       }
+       assign_double(ptr, creal(result));
+     } else {
+       assign_complex_num(ptr, result);
+     }
+     return ptr;
+     ")
 ))

scheme/read.sld

@@ -294,7 +294,10 @@
                                    (substring t 0 end)
                                    (substring t end (- len 1))))
                      (real (string->number real-str))
-                     (imag (string->number imag-str))
+                     (imag (cond
+                             ((equal? "+" imag-str) 1)  ;; Special case, +i w/no number
+                             ((equal? "-" imag-str) -1) ;; Special case, -i
+                             (else (string->number imag-str))))
                     )
                 (Cyc-make-rect real imag)))
              (else

scheme/repl.sld

@@ -20,9 +20,9 @@
     (define (repl)
       (with-handler
         (lambda (obj)
-          (display "Error: ")
           (cond
             ((error-object? obj)
+             (display "Error: ")
              (display (error-object-message obj))
              (if (not (null? (error-object-irritants obj)))
                  (display ": "))
@@ -31,18 +31,8 @@
                  (write o)
                  (display " "))
                (error-object-irritants obj)))
-            ((pair? obj)
-             (when (string? (car obj))
-               (display (car obj))
-               (if (not (null? (cdr obj)))
-                   (display ": "))
-               (set! obj (cdr obj)))
-             (for-each
-               (lambda (o)
-                 (write o)
-                 (display " "))
-               obj))
             (else
+              (display "Error: ")
               (display obj)))
           (newline)
           (repl))

srfi/106.sld

@@ -388,7 +388,7 @@
 #ifdef AI_V4MAPPED
       return_closcall1(data, k, obj_int2obj(AI_V4MAPPED)); 
 #else
-      Cyc_rt_raise_msg(data, \"AI_V4MAPPED is not available on this platform\");
+      return_closcall1(data, k, obj_int2obj(0)); 
 #endif
       ")
     (define *ai-all* (ai-all))
@@ -398,7 +398,7 @@
 #ifdef AI_ALL
       return_closcall1(data, k, obj_int2obj(AI_ALL)); 
 #else
-      Cyc_rt_raise_msg(data, \"AI_ALL is not available on this platform\");
+      return_closcall1(data, k, obj_int2obj(0)); 
 #endif
       ")
     (make-const ai-addrconfig  "AI_ADDRCONFIG" )

srfi/18.sld

@@ -74,6 +74,7 @@
         ;; - internal
         ;; - end of thread cont (or #f for default)
         ;; - end-result - Result of thread that terminates successfully
+        ;; - internal thread context at termination, e.g. parameterised objects
         (vector 
           'cyc-thread-obj 
           thunk 
@@ -82,6 +83,7 @@
           #f 
           #f
           #f
+          #f
           #f)))
 
     (define (thread-name t) (vector-ref t 3))
@@ -98,7 +100,7 @@
       (%get-thread-data))
 
     (define *primordial-thread*
-      (vector 'cyc-thread-obj #f #f "main thread" #f #f))
+      (vector 'cyc-thread-obj #f #f "main thread" #f #f #f #f))
 
     (define-c %current-thread
       "(void *data, int argc, closure _, object k)"
@@ -118,13 +120,21 @@
         make_c_opaque(co, td);
         return_closcall1(data, k, &co); ")
 
+    (define-c %end-thread!
+      "(void *data, int argc, closure _, object k, object ret)"
+      " gc_thread_data *d = data;
+        vector_type *v = d->scm_thread_obj;
+        v->elements[7] = ret;     // Store thread result
+        Cyc_end_thread(d);
+        return_closcall1(data, k, boolean_f);")
+
     (define (thread-start! t)
       ;; Initiate a GC prior to running the thread, in case
       ;; it contains any closures on the "parent" thread's stack
       (let* ((thunk (vector-ref t 1)) 
              (thread-params (cons t (lambda ()
                                       (vector-set! t 5 #f)
-                                      (thunk)))))
+                                      (let ((r (thunk))) (%end-thread! r))))))
         (vector-set! t 5 (%get-thread-data)) ;; Temporarily make parent thread
                                              ;; data available for child init
         (Cyc-minor-gc)
@@ -132,9 +142,33 @@
         t))
 
     (define (thread-yield!) (thread-sleep! 1))
-    (define-c thread-terminate!
-      "(void *data, object _, int argc, object *args)"
-      " Cyc_end_thread(data); ")
+
+    (define-c %thread-terminate!
+      "(void *data, int argc, closure _, object k, object thread_data_opaque)"
+      " gc_thread_data *td;
+        if (thread_data_opaque == boolean_f) {
+          /* primordial thread */
+          __halt(boolean_f);
+        } else {
+          td = (gc_thread_data *)(opaque_ptr(thread_data_opaque));
+          if (td == data) {
+            Cyc_end_thread(td);
+          } else {
+            pthread_cancel(td->thread_id);
+          }
+        }
+        return_closcall1(data, k, boolean_t);")
+    (define (thread-terminate! t)
+      (cond
+       ((and (thread? t)
+             (or (Cyc-opaque? (vector-ref t 2)) (equal? *primordial-thread* t)))
+        (begin
+         (Cyc-minor-gc)
+         (vector-set! t 5 (%get-thread-data)) ;; remember calling thread
+         (%thread-terminate! (vector-ref t 2))
+         #t))
+       (else
+        #f))) ;; TODO: raise an error instead?
 
     ;; TODO: not good enough, need to return value from thread
     ;; TODO: perhaps not an ideal solution using a loop/polling below, but good
@@ -156,6 +190,7 @@
       (cond
        ((and (thread? t) (Cyc-opaque? (vector-ref t 2)))
         (%thread-join! (vector-ref t 2))
+        (Cyc-minor-gc)
         (vector-ref t 7))
        (else
         #f))) ;; TODO: raise an error instead?

test-lib.c

@@ -0,0 +1,51 @@
+#include <stdio.h>
+#include <assert.h>
+#include "include/cyclone/types.h"
+#include "include/cyclone/runtime.h"
+#include "include/cyclone/runtime-main.h"
+
+/* Future considerations:
+int main(int argc, char **argv, char **envp)
+{gc_thread_data *thd;
+ long stack_size = global_stack_size = STACK_SIZE;
+ long heap_size = global_heap_size = HEAP_SIZE;
+ init_polyfills();
+ mclosure0(clos_halt,&Cyc_halt);  // Halt if final closure is reached
+ mclosure0(entry_pt,&c_entry_pt); // First function to execute
+ _cyc_argc = argc;
+ _cyc_argv = argv;
+ set_env_variables(envp);
+ gc_initialize();
+ thd = malloc(sizeof(gc_thread_data));
+ gc_thread_data_init(thd, 0, (char *) &stack_size, stack_size);
+ thd->gc_cont = &entry_pt;
+ thd->gc_args[0] = &clos_halt;
+ thd->gc_num_args = 1;
+ thd->thread_id = pthread_self();
+ gc_add_mutator(thd);
+ Cyc_heap_init(heap_size);
+ thd->thread_state = CYC_THREAD_STATE_RUNNABLE;
+ Cyc_start_trampoline(thd);
+ return 0;}
+ */
+
+void test_exact() {
+  common_type ptr;
+  make_double(d, 42.5);
+  assert(obj_int2obj(42) == Cyc_exact_no_cps(NULL, &ptr, obj_int2obj(42)));
+  object result = Cyc_exact_no_cps(NULL, &ptr, &d);
+  assert( result == obj_int2obj(43));
+
+  // TODO: unit tests for below as examples:
+  //void Cyc_exact(void *data, object cont, object z)
+}
+
+int main(){
+  assert(boolean_t == boolean_t);
+  assert(boolean_t != boolean_f);
+
+  test_exact();
+
+  printf("All tests passed successfully!\n");
+  return 0;
+}

tests/base.scm

@@ -9,6 +9,9 @@
 
 (import 
   (scheme base)
+  (scheme eval)
+  (scheme inexact)
+  (scheme write)
   (cyclone test))
 
 
@@ -30,6 +33,12 @@
   (test '() (make-list -2))
 )
 
+(test-group
+  "apply"
+  (test '(5 1 2) (eval '(apply cons '(5 (1 2)))))
+  (test '(5 1 2) (apply cons '(5 (1 2))))
+)
+
 (cond-expand
   (memory streams
     (test-group
@@ -46,6 +55,7 @@
       (test "o" (read-line p))
     )
   )
+  (else #f)
 )
 
 (test-group
@@ -102,6 +112,18 @@
   (test 2.0 (denominator (inexact (/ 6 4))))
 )
 
+(test-group
+  "sqrt"
+  (test 1i (sqrt -1))
+  (test 1i (sqrt -1.0))
+  (test +i (sqrt -1.0))
+  (test 2 (sqrt 4))
+  (test 2.0 (sqrt 4.0))
+  (test 2i (sqrt -4.0))
+  (test #t (complex? (sqrt -1)))
+  (test #t (complex? (sqrt -i)))
+)
+
 (test-group
   "exact"
   (test -1 (exact -1))
@@ -151,5 +173,45 @@
   (test #f (memq 0.0 (list m)))
 )
 
+(test-group
+  "exception handling"
+  (define (capture-output thunk)
+    (let ((output-string (open-output-string)))
+      (parameterize ((current-output-port output-string))
+        (thunk))
+      (let ((result (get-output-string output-string)))
+       (close-output-port output-string)
+       result)))
+  (test
+    "should be a number65"
+    (capture-output
+      (lambda ()
+        (with-exception-handler
+          (lambda (con)
+            (cond
+              ((string? con)
+               (display con))
+              (else
+               (display "a warning has been issued")))
+            42)
+          (lambda ()
+            (display
+              (+ (raise-continuable "should be a number")
+                 23)))))))
+  (test
+    "condition: an-error"
+    (capture-output
+      (lambda ()
+        (call-with-current-continuation
+          (lambda (k)
+            (with-exception-handler
+              (lambda (x)
+                (display "condition: ")
+                (write x)
+                (k "exception"))
+              (lambda ()
+                (+ 1 (raise 'an-error)))))))))
+)
+
 (test-exit)