Welcome to the CHICKEN Scheme pasting service

(define-syntax cc
  (er-macro-transformer
   (lambda (form r c)
     (##sys#check-syntax 'condition-case form '(_ _ . _))
     (let ((exvar (r 'exvar))
           (kvar (r 'kvar))
           (%and (r 'and))
           (%memv (r 'memv))
           (%else (r 'else)))
       `(,(r 'handle-exceptions) ,exvar
         (##core#let
          ((,kvar (,%and (##sys#structure?
                          ,exvar (##core#quote condition) )
                         (##sys#slot ,exvar 1))))
          (,(r 'cond)
           ,@(let lp ((seen-catchall? #f)
                      (clauses (cddr form))
                      (conditions '()))
               (if (null? clauses)
                   (##sys#fast-reverse
                    (if seen-catchall?
                        conditions
                        (cons `(,%else (##sys#signal ,exvar)) conditions)))
                   (let* ((clause (car clauses))
                          (var (and (symbol? (car clause)) (car clause)))
                          (kinds (if var (cadr clause) (car clause)))
                          (check (if (null? kinds)
                                     %else
                                     `(,%and
                                       ,kvar
                                       ,@(map (lambda (k)
                                                `(,%memv (##core#quote ,k)
                                                         ,kvar))
                                              kinds))))
                          (body (if var
                                    `(##core#let ((,var ,exvar))
                                                 ,@(cddr clause))
                                    `(##core#begin ,@(cdr clause)) )))
                     (if (and (null? kinds) (pair? (cdr clauses)))
                         (##sys#notice
                          "clauses following catchall clause in condition-case"
                          (##sys#strip-syntax clause)))
                     (lp (or (null? kinds) seen-catchall?)
                         (cdr clauses)
                         (cons `(,check ,body) conditions)) )))))
         ,(cadr form))))))

(define-syntax syntax-notice
  (er-macro-transformer
   (lambda (e r c)
     (##sys#check-syntax 'syntax-notice e '(_ _ . _))
     (apply ##sys#notice (strip-syntax (cdr e)))
     '(##sys#void))))

(define-syntax cc
  (syntax-rules ()
    ((_ "clauses" ?catchall ?exn ?kvar (() ?body) ?rest0 ?rest1 ...)
     (begin
       (syntax-notice "clauses following catch-all clause in condition-case"
                      (() ?body))
       (if #t
           ?body
           (cc "clauses" #t ?exn ?kvar ?rest0 ?rest1 ...))))
    ((_ "clauses" ?catchall ?exn ?kvar (?var () ?body) ?rest0 ?rest1 ...)
     (begin
       (syntax-notice "clauses following catch-all clause in condition-case"
                      (?var () ?body))
       (if #t
           (let ((?var ?exn)) ?body)
           (cc "clauses" #t ?exn ?kvar ?rest0 ?rest1 ...))))
    ((_ "clauses" ?catchall ?exn ?kvar ((?kind0 ...) ?body) ?rest ...)
     (if (and ?kvar (memv '?kind0 ?kvar) ...)
         ?body
         (cc "clauses" #t ?exn ?kvar ?rest ...)))
    ((_ "clauses" ?catchall ?exn ?kvar (?var (?kind0 ...) ?body) ?rest ...)
     (if (and ?kvar (memv '?kind0 ?kvar) ...)
         (let ((?var ?exn)) ?body)
         (cc "clauses" ?catchall ?exn ?kvar ?rest ...)))
    ((_ "clauses" #t ?exn ?kvar)
     (void))
    ((_ "clauses" #f ?exn ?kvar)
     (##sys#signal ?exn))
    ((_ ?body ?clauses ...)
     (handle-exceptions exn
         (let ((kvar (and (##sys#structure? exn 'condition)
                          (##sys#slot exn 1))))
           (cc "clauses" #f exn kvar ?clauses ...))
       ?body))))

(define-syntax cc
  (syntax-rules ()
    ((_ ?checked-expression ?clauses ...)
     (letrec-syntax
         ((cc-internal
           (macro-rules ()
            ((_ ?recur ?catchall ?exn ?kvar)
              (if ?catchall `(void) `(##sys#signal ,?exn)))
             ((_ ?recur ?catchall ?exn ?kvar ?clause . ?rest)
              (bind-case ?clause
                ((?var () ?body)
                 (if (not (null? ?rest))
                     (##sys#notice
                      "clauses following catch-all clause in condition-case"
                      `(,?var () ,?body)))
                 `(if #t
                      (let ((,?var ,?exn)) ,?body)
                      (,?recur ,?recur #t ,?exn ,?kvar . ,?rest)))
                ((() ?body)
                 (if (not (null? ?rest))
                   (##sys#notice
                    "clauses following catch-all clause in condition-case"
                    `(() ,?body)))
                 `(if #t
                      ,?body
                      (,?recur ,?recur #t ,?exn ,?kvar . ,?rest)))
                ((?var ?kinds ?body)
                 `(if (and ,?kvar ,@(map (lambda (k) `(memv ',k ,?kvar)) ?kinds))
                      (let ((,?var ,?exn)) ,?body)
                      (,?recur ,?recur ,?catchall ,?exn ,?kvar . ,?rest)))
                ((?kinds ?body)
                 `(if (and ,?kvar ,@(map (lambda (k) `(memv ',k ,?kvar)) ?kinds))
                      ,?body
                      (,?recur ,?recur ,?catchall ,?exn ,?kvar . ,?rest))))))))
      (handle-exceptions exn
          (let ((kvar (and (##sys#structure? exn 'condition)
                           (##sys#slot exn 1))))
            (cc-internal cc-internal #f exn kvar ?clauses ...))
        ?checked-expression)))))

(define-syntax cc
  (syntax-rules ()
    ((_ ?checked-expression ?clauses ...)
     (letrec-syntax
         ((cc-internal
           (macro-rules ()
            ((_ ?recur ?catchall ?exn ?kvar)
              (if ?catchall `(void) `(##sys#signal ,?exn)))
            ((_ ?recur ?catchall ?exn ?kvar ?clause . ?rest)
             (let* ((var (and (symbol? (car ?clause)) (car ?clause)))
                    (kinds (if var (cadr ?clause) (car ?clause)))
                    (body (if var (caddr ?clause) (cadr ?clause))))
              (if (and (null? kinds) (not (null? ?rest)))
                  (##sys#notice
                   "clauses following catch-all clause in condition-case"
                   (strip-syntax ?clause)))
              `(if ,(or (null? kinds)
                        `(and ,?kvar
                              ,@(map (lambda (k) `(memv ',k ,?kvar)) kinds)))
                   (let ,(if var `((,var ,?exn)) '()) ,body)
                   (,?recur ,?recur ,?catchall ,?exn ,?kvar . ,?rest)))))))
      (handle-exceptions exn
          (let ((kvar (and (##sys#structure? exn 'condition)
                           (##sys#slot exn 1))))
            (cc-internal cc-internal #f exn kvar ?clauses ...))
        ?checked-expression)))))