Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

The guard-like macro in the core language is now called protect.

Browse source 
This is the recommended syntax for error-handling in Chibi-specific
programs, since it's not possible to get stack traces when using
R[67]RS guard.  guard is defined separately and according to the
standard in (scheme base).
This commit is contained in:
Alex Shinn 2013-06-15 18:43:44 +09:00
parent 053f293e5e
commit d7db3effa8
10 changed files with 111 additions and 77 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/chibi/doc.scm
View file

@ -216,7 +216,7 @@
(div (^ (class . "result"))
,(call-with-output-string
(lambda (out)
(guard (exn (#t (print-exception exn out)))
(protect (exn (#t (print-exception exn out)))
(let ((res (eval expr example-env)))
(display "=> " out)
(write res out))))))))))

4
lib/chibi/highlight.scm
View file

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

4
lib/chibi/net/server.scm
View file

@ -27,13 +27,13 @@
(define (run sock addr count)
(log-debug "net-server: accepting request:" count)
(let ((ports
(guard (exn
(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
(protect (exn
(else (log-error "net-server: error in request:" count)
(print-exception exn)
(print-stack-trace exn)

4
lib/chibi/reload.scm
View file

@ -22,7 +22,7 @@
(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)
(protect (exn (else (warn "Error loading module definition" module-name)
(print-exception exn)
(print-stack-trace)
(add-module! module-name old-module)))
@ -31,7 +31,7 @@
(cond
((not module) (warn "Couldn't find module" module-name))
(else
(guard (exn (else (warn "Error loading module" module-name)
(protect (exn (else (warn "Error loading module" module-name)
(print-exception exn)
(print-stack-trace)
(delete-module! module-name)

20
lib/chibi/repl.scm
View file

@ -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 <identifier> [<module>]\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)))))

4
lib/chibi/term/edit-line.scm
View file

@ -613,7 +613,7 @@
(buffer-insert! buf out ch))
(define (command/enter ch buf out return)
(guard (exn (else
(protect (exn (else
(buffer-clear buf out)
(print-exception exn out)
(buffer-draw buf out)))
@ -771,7 +771,7 @@
((keymap? x)
(lp x))
((procedure? x)
(guard (exn (else
(protect (exn (else
(buffer-clear buf out)
(print-exception exn out)
(buffer-draw buf out)))

8
lib/chibi/test.sld
View file

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

46
lib/init-7.scm
View file

@ -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)
(call-with-current-continuation
(lambda (protect-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))))))))))))
(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)))))

2
lib/meta.scm
View file

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

40
lib/scheme/misc-macros.scm
View file

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