From 924911569f4f7fe83bebeb4fa11c1f383b510a22 Mon Sep 17 00:00:00 2001
From: Yorick Hardy <yorickhardy@gmail.com>
Date: Sun, 16 Feb 2025 11:56:20 +0200
Subject: [PATCH] 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.c       | 29 +++++++++++++++++------------
 scheme/base.sld |  9 ++++++---
 2 files changed, 23 insertions(+), 15 deletions(-)

diff --git a/runtime.c b/runtime.c
index dccc07fe..74a0f719 100644
--- a/runtime.c
+++ b/runtime.c
@@ -708,22 +708,27 @@ object Cyc_default_exception_handler(void *data, object _, int argc,
   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 || !Cyc_is_symbol(car(err))) {
     Cyc_display(data, err, stderr);
   } else {
-    // 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
-      if (is_msg && is_object_type(car(err)) && type_of(car(err)) == string_tag) {
-        is_msg = 0;
-        Cyc_display(data, car(err), stderr);
-        if (cdr(err)) {
-          fprintf(stderr, ": ");
+    if (strncmp(((symbol) car(err))->desc, "error", 10) == 0) {
+      // 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
+        if (is_msg && is_object_type(car(err)) && type_of(car(err)) == string_tag) {
+          is_msg = 0;
+          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, "raised object: ");
+      Cyc_display(data, cdr(err), stderr);
     }
   }
 
diff --git a/scheme/base.sld b/scheme/base.sld
index 93cda120..a57279e2 100644
--- a/scheme/base.sld
+++ b/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)