From 74d0980b823dc2814edfeeed7ff40f7e5fd073ef Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 14 Oct 2012 23:27:16 +0900 Subject: [PATCH] Adding file-error? and read-error? predicates. --- eval.c | 4 ++-- include/chibi/sexp.h | 1 + lib/scheme/base.sld | 5 +++-- lib/scheme/extras.scm | 6 ++++++ sexp.c | 9 +++++++++ 5 files changed, 21 insertions(+), 4 deletions(-) diff --git a/eval.c b/eval.c index e4895137..828cf8a2 100644 --- a/eval.c +++ b/eval.c @@ -1086,7 +1086,7 @@ sexp sexp_open_input_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp path) { in = fopen(sexp_string_data(path), "r"); } while (!in && sexp_out_of_file_descriptors() && !count++); if (!in) - return sexp_user_exception(ctx, self, "couldn't open input file", path); + return sexp_file_exception(ctx, self, "couldn't open input file", path); #if SEXP_USE_GREEN_THREADS fcntl(fileno(in), F_SETFL, O_NONBLOCK); #endif @@ -1102,7 +1102,7 @@ sexp sexp_open_output_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp path) { out = fopen(sexp_string_data(path), "w"); } while (!out && sexp_out_of_file_descriptors() && !count++); if (!out) - return sexp_user_exception(ctx, self, "couldn't open output file", path); + return sexp_file_exception(ctx, self, "couldn't open output file", path); #if SEXP_USE_GREEN_THREADS fcntl(fileno(out), F_SETFL, O_NONBLOCK); #endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index ca00a8cd..1aec5569 100755 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -1373,6 +1373,7 @@ SEXP_API sexp sexp_make_output_string_port_op (sexp ctx, sexp self, sexp_sint_t SEXP_API sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp port); SEXP_API sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x); +SEXP_API sexp sexp_file_exception (sexp ctx, sexp self, const char *msg, sexp x); SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x); SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x); SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); diff --git a/lib/scheme/base.sld b/lib/scheme/base.sld index 7f7b784d..c8bc9855 100644 --- a/lib/scheme/base.sld +++ b/lib/scheme/base.sld @@ -23,7 +23,8 @@ define-record-type define-syntax define-values denominator do dynamic-wind else eof-object? eq? equal? eqv? error error-object-irritants error-object-message error-object? even? - exact exact-integer-sqrt exact-integer? exact? expt features floor + exact exact-integer-sqrt exact-integer? exact? expt features + file-error? floor flush-output-port for-each gcd get-output-bytevector get-output-string guard if import include include-ci inexact inexact? input-port? integer->char @@ -36,7 +37,7 @@ open-output-string or output-port? pair? parameterize peek-char peek-u8 port-open? port? positive? procedure? quasiquote quote quotient raise raise-continuable rational? rationalize read-bytevector - read-bytevector! read-char read-line read-u8 real? remainder + read-bytevector! read-char read-error? read-line read-u8 real? remainder reverse round set! set-car! set-cdr! string string->list string->number string->symbol string->utf8 string->vector string-append string-copy string-fill! string-for-each string-length string-map diff --git a/lib/scheme/extras.scm b/lib/scheme/extras.scm index f0593d8c..e676156d 100644 --- a/lib/scheme/extras.scm +++ b/lib/scheme/extras.scm @@ -23,6 +23,12 @@ ((null? files) (cons (rename 'begin) (reverse res))) (else (lp (cdr files) (append (read-sexps (car files) #t) res)))))))) +(define (read-error? x) + (and (error-object? x) (eq? 'read (exception-type x)))) + +(define (file-error? x) + (and (error-object? x) (eq? 'file (exception-type x)))) + (define (features) *features*) (define exact inexact->exact) diff --git a/sexp.c b/sexp.c index 239cc00b..20b5420f 100644 --- a/sexp.c +++ b/sexp.c @@ -536,6 +536,15 @@ sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { return res; } +sexp sexp_file_exception (sexp ctx, sexp self, const char *ms, sexp ir) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_user_exception(ctx, self, ms, ir); + sexp_exception_kind(res) = sexp_intern(ctx, "file", -1); + sexp_gc_release1(ctx); + return res; +} + static sexp type_exception (sexp ctx, sexp self, sexp str, sexp obj, sexp src) { sexp_gc_var2(res, sym); sexp_gc_preserve2(ctx, res, sym);