Kaz Kylheku
8/15/2015 4:50:00 PM
On 2015-08-15, Taoufik Dachraoui <dachraoui.taoufik@gmail.com> wrote:
> Hi
>
> May be the following is useful for someone
>
(defmacro catch-case (form &rest cases)
(let ((r (gensym))
(a (loop for i in cases collect (cons (car i) (gensym))))
(b (loop for i in cases collect (cons (car i) (gensym)))))
`(let (,r ,@(loop for i in a collect (cdr i)))
(declare (special ,@(loop for i in b collect (cdr i))))
,(reduce #'(lambda (q p)
`(setq ,(cdr (assoc (car p) b))
(catch ,(car p) ,q (setq ,(cdr (assoc (car p) a)) t))))
(cons `(setq ,r ,form) (reverse cases)))
(cond
,@(loop for p in cases
collect `((null ,(cdr (assoc (car p) a)))
,(if (null (cdr p))
(cdr (assoc (car p) b))
(cadr p))))
(t ,r)))))
>
> ? (catch-case (throw 'a 5) ('a 2) ('b 3))
This is macro; why the quoting in the syntax?
(catch-case <try-expr> {(<sym> <catch-expr>)}*)
(Or do you expect the symbols to be the results of evaluation? That
seems overkill. A variant macro like catch-case* can be provided
to support that rare use case.)
Implementation:
(defmacro catch-case (try-expr &rest clauses)
(let ((normal-ret-sym (gensym))
(try-ret-tmp (gensym))
(catch-tmp (gensym)))
(labels ((expander (try-expr clauses)
(cond ((null clauses) try-expr)
((atom clauses) (error "catch-case: bad syntax"))
(t (destructuring-bind
(sym &optional (expr nil expr-present-p)) (first clauses)
(expander `(let* (,try-ret-tmp
(,catch-tmp (catch ',sym
(setf ,try-ret-tmp
,try-expr)
',normal-ret-sym)))
(if (eq ,catch-tmp ',normal-ret-sym)
,try-ret-tmp
,(if expr-present-p expr catch-tmp)))
(rest clauses)))))))
(expander try-expr clauses))))
Some tests:
[1]> (catch-case 42)
42
[2]> (catch-case nil)
NIL
[3]> (catch-case (throw 'x 42))
*** - THROW: there is no CATCHer for tag X
The following restarts are available:
ABORT :R1 Abort main loop
Break 1 [4]> :a
[5]> (catch-case 42 (a))
42
[6]> (catch-case (throw 'a 42) (a))
42
[7]> (catch-case 42 (a 1))
42
[8]> (catch-case (throw 'a 42) (a))
42
[9]> (catch-case (throw 'a 42) (a 1))
1
[10]> (catch-case (throw 'a 42) (a 1) (b 2) (c) (d 4))
1
[11]> (catch-case (throw 'b 42) (a 1) (b 2) (c) (d 4))
2
[12]> (catch-case (throw 'c 42) (a 1) (b 2) (c) (d 4))
42
[13]> (catch-case (throw 'd 42) (a 1) (b 2) (c) (d 4))
4
[14]> (catch-case (throw 'x 42) (a 1) (b 2) (c) (d 4))
*** - THROW: there is no CATCHer for tag X
The following restarts are available:
ABORT :R1 Abort main loop