* Added with-exception-handler, raise, and raise-continuable.

scheme/Makefile.am

@@ -1,6 +1,6 @@
 
 nodist_bin_SCRIPTS=ikarus.boot
-EXTRA_DIST=ikarus.boot.orig ikarus.apply.ss ikarus.bytevectors.ss ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss ikarus.compiler.altcogen.ss ikarus.compiler.ss ikarus.control.ss ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss ikarus.hash-tables.ss ikarus.intel-assembler.ss ikarus.io-ports.ss ikarus.io-primitives.ss ikarus.io-primitives.unsafe.ss ikarus.io.input-files.ss ikarus.io.input-strings.ss ikarus.io.output-files.ss ikarus.io.output-strings.ss ikarus.lists.ss ikarus.load.ss ikarus.main.ss ikarus.multiple-values.ss ikarus.numerics.ss ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss ikarus.records.procedural.ss ikarus.conditions.ss  ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss ikarus.transcoders.ss ikarus.unicode-data.ss ikarus.vectors.ss ikarus.writer.ss makefile.ss pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss psyntax.compat.ss psyntax.config.ss psyntax.expander.ss psyntax.internal.ss psyntax.library-manager.ss r6rs-records.ss ikarus/code-objects.ss ikarus/compiler.ss ikarus/intel-assembler.ss ikarus/fasl/write.ss unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss
+EXTRA_DIST=ikarus.boot.orig ikarus.exceptions.ss ikarus.apply.ss ikarus.bytevectors.ss ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss ikarus.compiler.altcogen.ss ikarus.compiler.ss ikarus.control.ss ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss ikarus.hash-tables.ss ikarus.intel-assembler.ss ikarus.io-ports.ss ikarus.io-primitives.ss ikarus.io-primitives.unsafe.ss ikarus.io.input-files.ss ikarus.io.input-strings.ss ikarus.io.output-files.ss ikarus.io.output-strings.ss ikarus.lists.ss ikarus.load.ss ikarus.main.ss ikarus.multiple-values.ss ikarus.numerics.ss ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss ikarus.records.procedural.ss ikarus.conditions.ss  ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss ikarus.transcoders.ss ikarus.unicode-data.ss ikarus.vectors.ss ikarus.writer.ss makefile.ss pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss psyntax.compat.ss psyntax.config.ss psyntax.expander.ss psyntax.internal.ss psyntax.library-manager.ss r6rs-records.ss ikarus/code-objects.ss ikarus/compiler.ss ikarus/intel-assembler.ss ikarus/fasl/write.ss unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss
 
 all: $(nodist_bin_SCRIPTS)
 

scheme/ikarus.exceptions.ss

@@ -0,0 +1,47 @@
+
+(library (ikarus exceptions)
+  (export with-exception-handler raise raise-continuable)
+  (import 
+    (only (rnrs) condition make-non-continuable-violation
+          make-message-condition)
+    (except (ikarus)
+      with-exception-handler raise raise-continuable))
+
+  (define (print-condition x)
+    (printf "CONDITION: ~s\n" x))
+
+  (define handlers
+    (make-parameter
+      (list 
+        (lambda (x) 
+          (printf "unhandled exception:\n")
+          (print-condition x)
+          (exit -1)))))
+  
+  (define (with-exception-handler handler proc2)
+    (unless (procedure? handler)
+      (error 'with-exception-handler
+        "handler ~s is not a procedure" handler))
+    (unless (procedure? proc2)
+      (error 'with-exception-handler
+        "~s is not a procedure" proc2))
+    (parameterize ([handlers (cons handler (handlers))])
+      (proc2)))
+  
+  (define (raise-continuable x)
+    (let ([h* (handlers)])
+      (let ([h (car h*)] [h* (cdr h*)])
+        (parameterize ([handlers h*])
+          (h x)))))
+  
+  (define (raise x)
+    (let ([h* (handlers)])
+      (let ([h (car h*)] [h* (cdr h*)])
+        (parameterize ([handlers h*])
+          (h x)
+          (raise
+            (condition
+              (make-non-continuable-violation)
+              (make-message-condition "handler returned")))))))
+)
+

scheme/makefile.ss

@@ -29,6 +29,7 @@
     "ikarus.handlers.ss"
     "ikarus.multiple-values.ss"
     "ikarus.control.ss"
+    "ikarus.exceptions.ss"
     "ikarus.collect.ss"
     "ikarus.apply.ss"
     "ikarus.predicates.ss"

scheme/todo-r6rs.ss

@@ -18,8 +18,12 @@
     [ne (null-environment)]
     [sr (rnrs sorting (6))]
     [ls (rnrs lists (6))]
-    [ba (rnrs base (6))]
+    [ri (rnrs records inspection (6))]
+    [rp (rnrs records procedural (6))]
+    [rs (rnrs records syntactic (6))]
+    [co (rnrs conditions (6))]
     [is (rnrs io simple (6))]
+    [ba (rnrs base (6))]
     [bv (rnrs bytevectors (6))]
     [uc (rnrs unicode (6))]
     [ex (rnrs exceptions (6))]
@@ -29,10 +33,6 @@
     [ht (rnrs hashtables (6))]
     [ip (rnrs io ports (6))]
     [en (rnrs enums (6))]
-    [co (rnrs conditions (6))]
-    [ri (rnrs records inspection (6))]
-    [rp (rnrs records procedural (6))]
-    [rs (rnrs records syntactic (6))]
     ))
 
 (define status-names
@@ -489,9 +489,9 @@
     [environment                                C ev]
     [eval                                       C ev se]
     ;;;
-    [raise                                      S ex]
+    [raise                                      C ex]
-    [raise-continuable                          S ex]
+    [raise-continuable                          C ex]
-    [with-exception-handler                     S ex]
+    [with-exception-handler                     C ex]
     [guard                                      S ex]
     ;;;
     [binary-port?                               S ip]