Hello,
I attach two implementations of srfi-34's "guard" syntax. (Depending
only of srfi-18; no additional procedures.)
I'd like to ask Elf, or whoever can do so and cares, to update the egg
(since the version there is broken).
However I'm left with a question: which version would one prefer? So
far I've got (from watching the mailing list) the feeling that
define-macro and define-syntax don't play well together.
Also I'm unsure whether all programs using define-syntax macros need to
require syntax-case, do they? If so, would there be trouble with
define-macro in those files?
If it was better to have both versions available, the define-macro
version for compatibility and define-syntax for the upcoming hygienic
chicken, then: how should this be handled? Two eggs?
Best regards
/Jörg
(define-macro (guard . form)
(let* ((clause (or (and (pair? form) (car form))
(error "guard: syntax error in" form)))
(body (cdr form))
(condition (gensym))
(handler-k (gensym))
(return (gensym))
(oldh (gensym)))
`((call-with-current-continuation
(lambda (,return)
(let ((,oldh (current-exception-handler)))
(with-exception-handler
(lambda (,condition)
(with-exception-handler
,oldh
(call-with-current-continuation
(lambda (,handler-k)
(,return (lambda ()
((lambda (,(car clause))
,(let loop ((clauses (cdr clause)))
(if (null? clauses)
`(raise ,(car clause))
(let ((c (car clauses)))
(cond
((eq? 'else (car c))
(if (null? (cdr c))
'#f
(if (null? (cddr c))
(cadr c)
`(begin . ,(cdr c)))))
((and (pair? c) (pair? (cdr c)) (eq? '=> (cadr c)))
(let ((v (gensym)))
`(let ((,v ,(car c)))
(if ,v (,(caddr c)) ,(loop (cdr clauses))))))
((and (pair? c) (null? (cdr c)))
(let ((v (gensym)))
`(let ((,v ,(car c)))
(if ,v ,v ,(loop (cdr clauses))))))
((pair? c)
`(if ,(car c)
,(if (null? (cddr c))
(cadr c)
`(begin . ,(cdr c)))
,(loop (cdr clauses))))
(else (error "guard syntax error in ~a" c)))))))
,condition)))))))
(lambda ()
(##sys#call-with-values
(lambda ()
,(if (and (pair? body) (null? (cdr body)))
(car body) `(begin . ,body) ))
(lambda args
(,return (lambda () (##sys#apply ##sys#values args)))) ) ) )) ) ))))
(define-syntax guard
(syntax-rules ()
((guard (var clause ...) e1 e2 ...)
((call-with-current-continuation
(lambda (guard-k)
(let ((oldh (current-exception-handler)))
(with-exception-handler
(lambda (condition)
(with-exception-handler
oldh
(call-with-current-continuation
(lambda (handler-k)
(guard-k
(lambda ()
(let ((var condition)) ; clauses may SET! var
(guard-aux (handler-k (lambda ()
(raise condition)))
clause ...))))))))
(lambda ()
(call-with-values
(lambda () e1 e2 ...)
(lambda args
(guard-k (lambda ()
(apply values args))))))))))))))
(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))
test)
((guard-aux reraise (test) clause1 clause2 ...)
(let ((temp test))
(if temp
temp
(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 ...)))))
_______________________________________________
Chicken-users mailing list
Chicken-users@nongnu.org
http://lists.nongnu.org/mailman/listinfo/chicken-users
