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

adding syntax-error, guard, distinguishing (non-)continuable exceptions

Browse source
This commit is contained in:
Alex Shinn 2011-03-28 22:09:13 +09:00
parent 5cf04597c1
commit 3b14c5ae7b
1 changed files with 52 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

73
lib/init.scm
View file

@ -300,22 +300,6 @@
(lambda (expr rename compare)
`(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exceptions
(define (error msg . args)
(raise (make-exception 'user msg args #f #f)))
(define (with-exception-handler handler thunk)
(letrec ((orig-handler (current-exception-handler))
(self (lambda (exn)
(current-exception-handler orig-handler)
(handler exn))))
(current-exception-handler self)
(let ((res (thunk)))
(current-exception-handler orig-handler)
res)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; library functions
@ -612,11 +596,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syntax-rules
(define-syntax syntax-error
(er-macro-transformer
(lambda (expr rename compare)
(apply error (cdr expr)))))
(define-syntax syntax-rules
(er-macro-transformer
(lambda (expr rename compare)
@ -827,11 +806,63 @@
(list (list _error "no expansion for"
(list (rename 'strip-syntactic-closures) _expr)))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; additional syntax
(define-syntax syntax-error
(er-macro-transformer
(lambda (expr rename compare)
(apply error (cdr expr)))))
(define-syntax letrec*
(syntax-rules ()
((letrec* ((var val) ...) . body)
(let () (define var val) ... . body))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exceptions
(define (error msg . args)
(raise (make-exception 'user msg args #f #f)))
(define *continuable* (list 'continuable))
(define (raise-continuable exn)
(raise (list *continuable* exn)))
(define (with-exception-handler handler thunk)
(letrec ((orig-handler (current-exception-handler))
(self (lambda (exn)
(current-exception-handler orig-handler)
(dynamic-wind
(lambda () (current-exception-handler orig-handler))
(lambda ()
(cond
((and (pair? exn) (eq? *continuable* (car exn)))
(handler (cadr exn)))
(else
(handler exn)
(error "exception handler returned"))))
(lambda () (current-exception-handler self))))))
(dynamic-wind
(lambda () (current-exception-handler self))
thunk
(lambda () (current-exception-handler orig-handler)))))
(define-syntax guard
(syntax-rules (else)
((guard (var (test . handler) ... (else . else-handler)) body ...)
(call-with-current-continuation
(lambda (return)
(with-exception-handler
(lambda (var)
(return
(cond (test . handler) ...
(else . else-handler))))
(lambda () body ...)))))
((guard (var (test . handler) ...) body ...)
(guard (var (test . handler) ... (else (raise var))) body ...))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; modules