Raise errors and objects with different tags (#557)

* 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

runtime.c

@@ -706,24 +706,30 @@ 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 {
-    // Error is list of form (type arg1 ... argn)
+    if (strncmp(((symbol) car(err))->desc, "error", 5) == 0) {
-    err = cdr(err);             // skip type field
+      fprintf(stderr, "Error: ");
-    for (; (err != NULL); err = cdr(err)) {     // output with no enclosing parens
+      // Error is list of form (type arg1 ... argn)
-      if (is_msg && is_object_type(car(err)) && type_of(car(err)) == string_tag) {
+      err = cdr(err);             // skip type field
-        is_msg = 0;
+      for (; (err != NULL); err = cdr(err)) {     // output with no enclosing parens
-        Cyc_display(data, car(err), stderr);
+        if (is_msg && is_object_type(car(err)) && type_of(car(err)) == string_tag) {
-        if (cdr(err)) {
+          is_msg = 0;
-          fprintf(stderr, ": ");
+          Cyc_display(data, car(err), stderr);
+          if (cdr(err)) {
+            fprintf(stderr, ": ");
+          }
+        } else {
+          Cyc_write(data, car(err), stderr);
+          fprintf(stderr, " ");
         }
-      } else {
-        Cyc_write(data, car(err), stderr);
-        fprintf(stderr, " ");
       }
+    } else {
+      fprintf(stderr, "Error: ");
+      Cyc_display(data, cdr(err), stderr);
     }
   }
 

scheme/base.sld

@@ -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)

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))

tests/base.scm

@@ -11,6 +11,7 @@
   (scheme base)
   (scheme eval)
   (scheme inexact)
+  (scheme write)
   (cyclone test))
 
 
@@ -172,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)