From 2b0f0601a6ca8e3ab05b7cc946547d71acd6c6cc Mon Sep 17 00:00:00 2001 From: yorickhardy <45015436+yorickhardy@users.noreply.github.com> Date: Sun, 23 Feb 2025 23:23:16 +0200 Subject: [PATCH] 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 | 32 +++++++++++++++++++------------- scheme/base.sld | 9 ++++++--- scheme/repl.sld | 14 ++------------ tests/base.scm | 41 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 68 insertions(+), 28 deletions(-) diff --git a/runtime.c b/runtime.c index dccc07fe..6243933a 100644 --- a/runtime.c +++ b/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) - 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", 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 + 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, "Error: "); + 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) diff --git a/scheme/repl.sld b/scheme/repl.sld index 6643ae60..49a9d147 100644 --- a/scheme/repl.sld +++ b/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)) diff --git a/tests/base.scm b/tests/base.scm index 28ff2539..c1e5f702 100644 --- a/tests/base.scm +++ b/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)