ntinuable-violation))))
             ((and (not (null? args))
                   (raise-object-wrapper? (car args)))
              (let* ((cargs (car args))
                     (obj (raise-object-wrapper-obj cargs))
                     (continuation (raise-object-wrapper-continuation cargs))
                     (handler-return (handler obj)))
                (if continuation
                    (continuation handler-return)
                    (raise (make-non-continuable-violation)))))))))

  (define-syntax guard0
    (syntax-rules ()
      ((_ (variable cond-clause ...) . body)
       (call/cc (lambda (continuation)
		  (with-exception-handler
		   (lambda (variable)
		     (continuation (cond cond-clause ...)))
		   (lambda () . body)))))))

  (define-syntax guard
    (syntax-rules (else)
      ((_ (variable cond-clause ... . ((else else-clause ...))) . body)
       (guard0 (variable cond-clause ... (else else-clause ...)) . body))
      ((_ (variable cond-clause ...) . body)
       (guard0 (variable cond-clause ... (else (raise variable))) . body))))

  ;;; Exception printing

  (define (exception-printer port key args punt)
    (cond ((and (= 1 (length args))
                (raise-object-wrapper? (car args)))
           (let ((obj (raise-object-wrapper-obj (car args))))
             (cond ((condition? obj)
                    (display "ERROR: R6RS exception:\n" port)
                    (format-condition port obj))
                   (else
                    (format port "ERROR: R6RS exception: `~s'" obj)))))
          (else
           (punt))))

  (define (format-condition port condition)
    (let ((components (simple-conditions condition)))
      (if (null? components)
          (format port "Empty condition object")
          (let loop ((i 1) (components components))
            (cond ((pair? components)
                   (format port "  ~a. " i)
                   (format-simple-condition port (car components))
                   (when (pair? (cdr components))
                     (newline port))
                   (loop (+ i 1) (cdr components))))))))

  (define (format-simple-condition port condition)
    (define (print-rtd-fields rtd field-names)
      (let ((n-fields (vector-length field-names)))
        (do ((i 0 (+ i 1)))
            ((>= i n-fields))
          (format port "      ~a: ~s"
                  (vector-ref field-names i)
                  ((record-accessor rtd i) condition))
          (unless (= i (- n-fields 1))
            (newline port)))))
    (let ((condition-name (record-type-name (record-rtd condition))))
      (let loop ((rtd (record-rtd condition))
                 (rtd.fields-list '())
                 (n-fields 0))
        (cond (rtd
               (let ((field-names (record-type-field-names rtd)))
                 (loop (record-type-parent rtd)
                       (cons (cons rtd field-names) rtd.fields-list)
                       (+ n-fields (vector-length field-names)))))
              (else
               (let ((rtd.fields-list
                      (filter (lambda (rtd.fields)
                                (not (zero? (vector-length (cdr rtd.fields)))))
                              (reverse rtd.fields-list))))
                 (case n-fields
                   ((0) (format port "~a" condition-name))
                   ((1) (format port "~a: ~s"
                                condition-name
                                ((record-accessor (caar rtd.fields-list) 0)
                                 condition)))
                   (else
                    (format port "~a:\n" condition-name)
                    (let loop ((lst rtd.fields-list))
                      (when (pair? lst)
                        (let ((rtd.fields (car lst)))
                          (print-rtd-fields (car rtd.fields) (cdr rtd.fields))
                          (when (pair? (cdr lst))
                            (newline port))
                          (loop (cdr lst)))))))))))))

  (set-exception-printer! 'r6rs:exception exception-printer)

  ;; Guile condition converters
  ;;
  ;; Each converter is a procedure (converter KEY ARGS) that returns
  ;; either an R6RS condition or #f.  If #f is returned,
  ;; 'default-guile-condition-converter' will be used.

  (define (guile-syntax-violation-converter key args)
    (apply (case-lambda
             ((who what where form subform . extra)
              (condition (make-syntax-violation form subform)
                         (make-who-condition who)
                         (make-message-condition what)))
             (_ #f))
           args))

  (define (guile-lexical-violation-converter key args)
    (condition (make-lexical-violation) (guile-common-conditions key args)))

  (define (guile-assertion-violation-converter key args)
    (condition (make-assertion-violation) (guile-common-conditions key args)))

  (define (guile-undefined-violation-converter key args)
    (condition (make-undefined-violation) (guile-common-conditions key args)))

  (define (guile-implementation-restriction-converter key args)
    (condition (make-implementation-restriction-violation)
               (guile-common-conditions key args)))

  (define (guile-error-converter key args)
    (condition (make-error) (guile-common-conditions key args)))

  (define (guile-system-error-converter key args)
    (apply (case-lambda
             ((subr msg msg-args errno . rest)
              ;; XXX TODO we should return a more specific error
              ;; (usually an I/O error) as expected by R6RS programs.
              ;; Unfortunately this often requires the 'filename' (or
              ;; other?) which is not currently provided by the native
              ;; Guile exceptions.
              (condition (make-error) (guile-common-conditions key args)))
             (_ (guile-error-converter key args)))
           args))

  ;; TODO: Arrange to have the needed information included in native
  ;;       Guile I/O exceptions, and arrange here to convert them to the
  ;;       proper conditions.  Remove the earlier exception conversion
  ;;       mechanism: search for 'with-throw-handler' in the 'rnrs'
  ;;       tree, e.g. 'with-i/o-filename-conditions' and
  ;;       'with-i/o-port-error' in (rnrs io ports).

  ;; XXX TODO: How should we handle the 'misc-error', 'vm-error', and
  ;;           'signal' native Guile exceptions?

  ;; XXX TODO: Should we handle the 'quit' exception specially?

  ;; An alist mapping native Guile exception keys to converters.
  (define guile-condition-converters
    `((read-error                . ,guile-lexical-violation-converter)
      (syntax-error              . ,guile-syntax-violation-converter)
      (unbound-variable          . ,guile-undefined-violation-converter)
      (wrong-number-of-args      . ,guile-assertion-violation-converter)
      (wrong-type-arg            . ,guile-assertion-violation-converter)
      (keyword-argument-error    . ,guile-assertion-violation-converter)
      (out-of-range              . ,guile-assertion-violation-converter)
      (regular-expression-syntax . ,guile-assertion-violation-converter)
      (program-error             . ,guile-assertion-violation-converter)
      (goops-error               . ,guile-assertion-violation-converter)
      (null-pointer-error        . ,guile-assertion-violation-converter)
      (system-error              . ,guile-system-error-converter)
      (host-not-found            . ,guile-error-converter)
      (getaddrinfo-error         . ,guile-error-converter)
      (no-data                   . ,guile-error-converter)
      (no-recovery               . ,guile-error-converter)
      (try-again                 . ,guile-error-converter)
      (stack-overflow            . ,guile-implementation-restriction-converter)
      (numerical-overflow        . ,guile-implementation-restriction-converter)
      (memory-allocation-error   . ,guile-implementation-restriction-converter)))

  (define (set-guile-condition-converter! key proc)
    (set! guile-condition-converters
          (acons key proc guile-condition-converters))))