diff --git a/lib/chibi/doc.scm b/lib/chibi/doc.scm index d46d3d66..04f16d67 100644 --- a/lib/chibi/doc.scm +++ b/lib/chibi/doc.scm @@ -216,10 +216,10 @@ (div (^ (class . "result")) ,(call-with-output-string (lambda (out) - (guard (exn (#t (print-exception exn out))) - (let ((res (eval expr example-env))) - (display "=> " out) - (write res out)))))))))) + (protect (exn (#t (print-exception exn out))) + (let ((res (eval expr example-env))) + (display "=> " out) + (write res out)))))))))) (define (expand-example-import x env) (eval `(import ,@(cdr x)) diff --git a/lib/chibi/highlight.scm b/lib/chibi/highlight.scm index 42c146ca..2f872df1 100644 --- a/lib/chibi/highlight.scm +++ b/lib/chibi/highlight.scm @@ -27,7 +27,7 @@ (define (highlight-detect-language str) (cond - ((guard (exn (else #f)) + ((protect (exn (else #f)) (call-with-input-string str (lambda (in) (do ((x #f (read in))) ((eof-object? x))))) #t) @@ -163,7 +163,7 @@ require-extension use use-modules import import-immutable define-module select-module provide autoload export only except rename prefix include include-shared - condition-case guard cond-expand for with to by + condition-case guard protect cond-expand for with to by in-list in-lists in-string in-string-reverse in-vector in-vector-reverse in-file listing appending summing multpliying up-from down-from else diff --git a/lib/chibi/net/server.scm b/lib/chibi/net/server.scm index 6ec40ca1..87edf950 100644 --- a/lib/chibi/net/server.scm +++ b/lib/chibi/net/server.scm @@ -27,19 +27,19 @@ (define (run sock addr count) (log-debug "net-server: accepting request:" count) (let ((ports - (guard (exn - (else - (log-error "net-server: couldn't create port:" sock) - (close-file-descriptor sock))) + (protect (exn + (else + (log-error "net-server: couldn't create port:" sock) + (close-file-descriptor sock))) (cons (open-input-file-descriptor sock) (open-output-file-descriptor sock))))) - (guard (exn - (else (log-error "net-server: error in request:" count) - (print-exception exn) - (print-stack-trace exn) - (close-input-port (car ports)) - (close-output-port (cdr ports)) - (close-file-descriptor sock))) + (protect (exn + (else (log-error "net-server: error in request:" count) + (print-exception exn) + (print-stack-trace exn) + (close-input-port (car ports)) + (close-output-port (cdr ports)) + (close-file-descriptor sock))) (handler (car ports) (cdr ports) sock addr) (close-input-port (car ports)) (close-output-port (cdr ports)) diff --git a/lib/chibi/reload.scm b/lib/chibi/reload.scm index 45f4c750..d65187f1 100644 --- a/lib/chibi/reload.scm +++ b/lib/chibi/reload.scm @@ -22,20 +22,20 @@ (let ((old-module (find-module module-name))) ;; Remove old entry in modules list. (delete-module! module-name) - (guard (exn (else (warn "Error loading module definition" module-name) - (print-exception exn) - (print-stack-trace) - (add-module! module-name old-module))) + (protect (exn (else (warn "Error loading module definition" module-name) + (print-exception exn) + (print-stack-trace) + (add-module! module-name old-module))) (load-module-definition module-name) (let ((module (find-module module-name))) (cond ((not module) (warn "Couldn't find module" module-name)) (else - (guard (exn (else (warn "Error loading module" module-name) - (print-exception exn) - (print-stack-trace) - (delete-module! module-name) - (add-module! module-name old-module))) + (protect (exn (else (warn "Error loading module" module-name) + (print-exception exn) + (print-stack-trace) + (delete-module! module-name) + (add-module! module-name old-module))) (let ((env (eval-module module-name module))) (%import (module-env module) env (env-exports env) #f))))))))) diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm index db6f3b6f..ae197203 100644 --- a/lib/chibi/repl.scm +++ b/lib/chibi/repl.scm @@ -41,7 +41,7 @@ (if (equal? res "") line res)) (else (let ((res (string-append res line "\n"))) - (if (guard (exn (else #f)) (complete-sexp? res)) + (if (protect (exn (else #f)) (complete-sexp? res)) res (lp res)))))))) @@ -140,7 +140,7 @@ ;;> @itemlist[ ;;> @item{@scheme{in:} - the input port (default @scheme{(current-input-port)})} ;;> @item{@scheme{out:} - the output port (default @scheme{(current-output-port)})} -;;> @item{@scheme{module:} - the initial module +;;> @item{@scheme{module:} - the initial module} ;;> @item{@scheme{environment:} - the initial environment (default @scheme{(interaction-environment)})} ;;> @item{@scheme{escape:} - the command escape character (default @scheme|{#\@}|)} ;;> @item{@scheme{make-prompt:} - a procedure taking one argument (the current module name as a list) and returning a string to be used as the prompt} @@ -185,7 +185,7 @@ (mod+imps (eval `(resolve-import ',mod-name) (repl-meta-env rp)))) (cond ((pair? mod+imps) - (guard + (protect (exn (else (print-exception exn (current-error-port)) @@ -250,7 +250,7 @@ (display "Try @help []\n" out)) ((null? (cddr args)) (let* ((failed (list 'failed)) - (val (guard (exn (else (print-exception exn) failed)) + (val (protect (exn (else (print-exception exn) failed)) (eval (second args) (repl-env rp)))) (mod (and (procedure? val) (containing-module val)))) (cond @@ -260,7 +260,7 @@ ((not (eq? val failed)) (describe val out))))) (else - (guard (exn (else (print-exception exn (current-error-port)))) + (protect (exn (else (print-exception exn (current-error-port)))) (print-module-binding-docs (third args) (second args) out)))) (continue rp))) @@ -281,13 +281,13 @@ (define (repl/eval rp expr-list) (let ((out (repl-out rp))) - (guard (exn (else (print-exception exn out))) + (protect (exn (else (print-exception exn out))) (let ((thread (make-thread (lambda () - ;; The inner guard in the child thread catches errors + ;; The inner protect in the child thread catches errors ;; from eval. - (guard (exn (else (print-exception exn out))) + (protect (exn (else (print-exception exn out))) (for-each (lambda (expr) (call-with-values (lambda () (eval expr (repl-env rp))) @@ -316,7 +316,7 @@ (define (repl/eval-string rp str) (repl/eval rp - (guard (exn (else (print-exception exn (current-error-port)))) + (protect (exn (else (print-exception exn (current-error-port)))) ;; Ugly wrapper to account for the implicit state mutation ;; implied by the #!fold-case read syntax. (let ((in (repl-in rp)) @@ -357,7 +357,7 @@ (history (cond ((memq 'history: o) => cadr) (else - (or (guard (exn (else #f)) + (or (protect (exn (else #f)) (list->history (call-with-input-file history-file read))) (make-history))))) diff --git a/lib/chibi/term/edit-line.scm b/lib/chibi/term/edit-line.scm index f356b9d5..eb934ac3 100644 --- a/lib/chibi/term/edit-line.scm +++ b/lib/chibi/term/edit-line.scm @@ -613,10 +613,10 @@ (buffer-insert! buf out ch)) (define (command/enter ch buf out return) - (guard (exn (else - (buffer-clear buf out) - (print-exception exn out) - (buffer-draw buf out))) + (protect (exn (else + (buffer-clear buf out) + (print-exception exn out) + (buffer-draw buf out))) (cond (((buffer-complete? buf) buf) (command/end-of-line ch buf out return) @@ -771,10 +771,10 @@ ((keymap? x) (lp x)) ((procedure? x) - (guard (exn (else - (buffer-clear buf out) - (print-exception exn out) - (buffer-draw buf out))) + (protect (exn (else + (buffer-clear buf out) + (print-exception exn out) + (buffer-draw buf out))) (x ch buf out return)) (flush-output out) (buffer-refresh buf out) diff --git a/lib/chibi/test.sld b/lib/chibi/test.sld index dc95cdbe..c2fe7325 100644 --- a/lib/chibi/test.sld +++ b/lib/chibi/test.sld @@ -9,15 +9,17 @@ current-test-applier current-test-handler current-test-skipper current-test-group-reporter test-failure-count current-test-epsilon current-test-comparator) - (import (scheme base) - (scheme write) + (import (scheme write) (scheme complex) (scheme process-context) (scheme time)) (cond-expand (chibi - (import (only (chibi) pair-source print-exception))) + (import (except (scheme base) guard) + (rename (only (chibi) pair-source print-exception protect) + (protect guard)))) (else + (import (scheme base)) (begin (define (pair-source x) #f) (define print-exception write)))) diff --git a/lib/init-7.scm b/lib/init-7.scm index 1567e385..64e21dc6 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -944,47 +944,39 @@ (error "exception handler returned")))))))) (%with-exception-handler self thunk))) -(define-syntax guard +(define-syntax protect (syntax-rules () - ((guard (var clause ...) e1 e2 ...) + ((protect (var clause ...) e1 e2 ...) (let ((orig-handler (current-exception-handler))) - ((call-with-current-continuation - (lambda (guard-k) - (with-exception-handler - (lambda (condition) - ((call-with-current-continuation - (lambda (handler-k) - (let* ((var condition) ; clauses may set! var - (res - (guard-aux - (handler-k (lambda () - (raise-continuable condition))) - clause ...))) - (guard-k (lambda () res))))))) - (lambda () - (let ((res (begin e1 e2 ...))) - (guard-k (lambda () res)))))))))))) + (call-with-current-continuation + (lambda (protect-k) + (with-exception-handler + (lambda (condition) + (let ((var condition)) ; clauses may set! var + (protect-k + (protect-aux (raise-continuable condition) clause ...)))) + (lambda () e1 e2 ...)))))))) -(define-syntax guard-aux +(define-syntax protect-aux (syntax-rules (else =>) - ((guard-aux reraise (else result1 result2 ...)) + ((protect-aux reraise (else result1 result2 ...)) (begin result1 result2 ...)) - ((guard-aux reraise (test => result)) + ((protect-aux reraise (test => result)) (let ((temp test)) (if temp (result temp) reraise))) - ((guard-aux reraise (test => result) clause1 clause2 ...) + ((protect-aux reraise (test => result) clause1 clause2 ...) (let ((temp test)) - (if temp (result temp) (guard-aux reraise clause1 clause2 ...)))) - ((guard-aux reraise (test)) + (if temp (result temp) (protect-aux reraise clause1 clause2 ...)))) + ((protect-aux reraise (test)) (or test reraise)) - ((guard-aux reraise (test) clause1 clause2 ...) - (or test (guard-aux reraise clause1 clause2 ...))) - ((guard-aux reraise (test result1 result2 ...)) + ((protect-aux reraise (test) clause1 clause2 ...) + (or test (protect-aux reraise clause1 clause2 ...))) + ((protect-aux reraise (test result1 result2 ...)) (if test (begin result1 result2 ...) reraise)) - ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...) + ((protect-aux reraise (test result1 result2 ...) clause1 clause2 ...) (if test (begin result1 result2 ...) - (guard-aux reraise clause1 clause2 ...))))) + (protect-aux reraise clause1 clause2 ...))))) (define (eval x . o) (let ((thunk (compile x (if (pair? o) (car o) (interaction-environment))))) diff --git a/lib/meta.scm b/lib/meta.scm index 72c5079b..8c4284e9 100644 --- a/lib/meta.scm +++ b/lib/meta.scm @@ -167,7 +167,7 @@ (%import env (module-env mod2) (cdr mod2-name+imports) #t))) (cdr x))))) meta) - (guard + (protect (exn (else (module-meta-data-set! mod meta) (if (not (any (lambda (x) diff --git a/lib/scheme/misc-macros.scm b/lib/scheme/misc-macros.scm index d4c07842..7b367671 100644 --- a/lib/scheme/misc-macros.scm +++ b/lib/scheme/misc-macros.scm @@ -8,3 +8,43 @@ (syntax-rules () ((unless test . body) (when (not test) . body)))) + +(define-syntax guard + (syntax-rules () + ((guard (var clause ...) e1 e2 ...) + ((call-with-current-continuation + (lambda (guard-k) + (with-exception-handler + (lambda (condition) + ((call-with-current-continuation + (lambda (handler-k) + (guard-k + (lambda () + (let ((var condition)) ; clauses may SET! var + (guard-aux (handler-k (lambda () + (raise-continuable condition))) + clause ...)))))))) + (lambda () + (let ((res (begin e1 e2 ...))) + (guard-k (lambda () res))))))))))) + +(define-syntax guard-aux + (syntax-rules (else =>) + ((guard-aux reraise (else result1 result2 ...)) + (begin result1 result2 ...)) + ((guard-aux reraise (test => result)) + (let ((temp test)) + (if temp (result temp) reraise))) + ((guard-aux reraise (test => result) clause1 clause2 ...) + (let ((temp test)) + (if temp (result temp) (guard-aux reraise clause1 clause2 ...)))) + ((guard-aux reraise (test)) + (or test reraise)) + ((guard-aux reraise (test) clause1 clause2 ...) + (or test (guard-aux reraise clause1 clause2 ...))) + ((guard-aux reraise (test result1 result2 ...)) + (if test (begin result1 result2 ...) reraise)) + ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...) + (if test + (begin result1 result2 ...) + (guard-aux reraise clause1 clause2 ...)))))