;; (C) 2008 Joerg F. Wittenberger see http://www.askemos.org

(declare
 (unit cndtnhndlng)
 (uses srfi-1 srfi-13 srfi-18 library)
 (fixnum-arithmetic)
 (disable-warning var redef)
 (not usual-integrations raise signal error current-exception-handler)
 (export
  make-condition-type condition-type? condition-type-name condition-types
  make-condition condition? condition-has-type?
  condition-ref make-compound-condition extract-condition
  &condition &message message-condition? condition-message
  &serious serious-condition? &error error?
  type-field-alist->condition check-condition-type-field-alist)
 (export 
  with-exception-guard raise signal error abort
  ##sys#error ##sys#signal
  current-exception-handler with-exception-handler
  )
 )

;(include "srfi34-syntax.scm")

;; REPLACE THE EXCEPTION HANDLER

;; unsure, shouldn't we wrap the handler with dynamic-wind ?

(define chicken-exception-handler (current-exception-handler))

(define srfi34:*current-exception-handlers*
  (make-parameter (list chicken-exception-handler)))

(define (srfi34:with-exception-handler handler thunk)
  (srfi34:with-exception-handlers
   (cons handler (srfi34:*current-exception-handlers*))
   thunk))

(define (srfi34:with-exception-handlers new-handlers thunk)
  (let ((previous-handlers (srfi34:*current-exception-handlers*)))
    (dynamic-wind
      (lambda ()
        (srfi34:*current-exception-handlers* new-handlers))
      thunk
      (lambda ()
        (srfi34:*current-exception-handlers* previous-handlers)))))

(define (srfi34:raise obj)
  (let ((handlers (srfi34:*current-exception-handlers*)))
    (srfi34:with-exception-handlers
     (cdr handlers)
     (lambda ()
       ((car handlers) obj)
       ;; (error "handler returned" (car handlers) obj)
       (chicken-exception-handler
	(make-property-condition
	 'exn 'message "exception handler returned"))))))

(set! with-exception-handler srfi34:with-exception-handler)

(set! current-exception-handler
      (lambda () (car (srfi34:*current-exception-handlers*))))

(set! ##sys#default-exception-handler current-exception-handler)

; (define (##sys#escape x)
;   (let ((handler-chain ##sys#current-exception-handler))
;     (set! ##sys#current-exception-handler
;           (cdr ##sys#current-exception-handler))
;     ((car handler-chain) x)
;     (set! ##sys#current-exception-handler handler-chain)))

;(define srfi-34:raise ##sys#escape)

(set! ##sys#abort
      (lambda (x)
        ((car (srfi34:*current-exception-handlers*)) x)
        (##sys#abort (make-property-condition
                      'exn 'message "exception handler returned")) ))

(set! ##sys#signal
      (lambda (x)
        ((car (srfi34:*current-exception-handlers*)) x)) )

(set! ##sys#current-exception-handler current-exception-handler)

(define raise srfi34:raise)
(set! abort ##sys#abort)
(set! signal ##sys#signal)
(set! error
      (lambda (msg . args)
	(let ((s (if (pair? args) (format #f "~a ~s" msg args) msg)))
	  (if (enable-warnings) (##sys#signal-hook #:warning s))
	  (srfi34:raise s))))

(set! ##sys#error error)

; (set! ##sys#current-exception-handler
;       (list ##sys#current-exception-handler))

; (set! with-exception-handler
;       (lambda (handler thunk)
;         (let ((handler-chain ##sys#current-exception-handler))
;           (##sys#dynamic-wind
;            (lambda () (set! ##sys#current-exception-handler
;                             (cons handler handler-chain)))
;            thunk
;            (lambda () (set! ##sys#current-exception-handler handler-chain)) ))) )

;; SRFI 34 support

(define (with-exception-guard handler thunk)
  ((call-with-current-continuation
    (lambda (return)
      (srfi34:with-exception-handler
       (lambda (condition)
         ((call-with-current-continuation
           (lambda (handler-k)
             (return (lambda ()
                       (srfi34:with-exception-handler
                        (lambda (condition) (handler-k (lambda () (srfi34:raise condition))))
			(lambda () (handler condition)))))))))
       (lambda ()
         (##sys#call-with-values
          thunk
          (lambda args
            (return (lambda () (##sys#apply ##sys#values args)))) ) ) ) ) )) )


;; SRFI 35 reference implementation
(define-record-type :condition-type
  (really-make-condition-type name supertype fields all-fields)
  condition-type?
  (name condition-type-name)
  (supertype condition-type-supertype)
  (fields condition-type-fields)
  (all-fields condition-type-all-fields))

(define (make-condition-type name supertype fields)
  (if (not (symbol? name))
      (error "make-condition-type: name is not a symbol"
             name))
  (if (not (condition-type? supertype))
      (error "make-condition-type: supertype is not a condition type"
             supertype))
  (if (not
       (null? (lset-intersection eq?
                                 (condition-type-all-fields supertype)
                                 fields)))
      (error "duplicate field name" ))
  (really-make-condition-type name
                              supertype
                              fields
                              (append (condition-type-all-fields supertype)
                                      fields)))
(define (condition-subtype? subtype supertype)
  (let recur ((subtype subtype))
    (cond ((not subtype) #f)
          ((eq? subtype supertype) #t)
          (else
           (recur (condition-type-supertype subtype))))))

(define (condition-type-field-supertype condition-type field)
  (let loop ((condition-type condition-type))
    (cond ((not condition-type) #f)
          ((memq field (condition-type-fields condition-type))
           condition-type)
          (else
           (loop (condition-type-supertype condition-type))))))

; The type-field-alist is of the form
; ((<type> (<field-name> . <value>) ...) ...)
(define-record-type :condition
  (really-make-condition type-field-alist)
  condition?*
  (type-field-alist condition-type-field-alist))

(define chicken-condition? condition?)

(define condition?
  (let ((orig condition?))
    (lambda (obj) (or (condition?* obj) (orig obj)))))

(define (make-condition type . field-plist)
  (let ((alist (let label ((plist field-plist))
                 (if (null? plist)
                            '()
                     (cons (cons (car plist)
                                 (cadr plist))
                           (label (cddr plist)))))))
    (if (not (lset= eq?
                    (condition-type-all-fields type)
                    (map car alist)))
        (error "condition fields don't match condition type"))
    (really-make-condition (list (cons type alist)))))

(define (condition-has-type? condition type)
  (and (condition?* condition)
       (any (lambda (has-type)
	      (condition-subtype? has-type type))
	    (condition-types condition))))

(define (condition-ref condition field)
  (type-field-alist-ref (condition-type-field-alist condition)
                        field))

(define (type-field-alist-ref type-field-alist field)
  (let loop ((type-field-alist type-field-alist))
    (cond ((null? type-field-alist)
           (error "type-field-alist-ref: field not found"
                  type-field-alist field))
          ((assq field (cdr (car type-field-alist)))
           => cdr)
          (else
           (loop (cdr type-field-alist))))))

(define (make-compound-condition condition-1 . conditions)
  (really-make-condition
   (apply append (map condition-type-field-alist
                      (cons condition-1 conditions)))))

(define (extract-condition condition type)
  (let ((entry (find (lambda (entry)
                              (condition-subtype? (car entry) type))
                            (condition-type-field-alist condition))))
    (if (not entry)
        (error "extract-condition: invalid condition type"
                      condition type))
    (really-make-condition
      (list (cons type
                  (map (lambda (field)
                         (assq field (cdr entry)))
                       (condition-type-all-fields type)))))))

(define (type-field-alist->condition type-field-alist)
  (really-make-condition
   (map (lambda (entry)
          (cons (car entry)
                (map (lambda (field)
                       (or (assq field (cdr entry))
                           (cons field
                                 (type-field-alist-ref type-field-alist field))))
                     (condition-type-all-fields (car entry)))))
        type-field-alist)))

(define (condition-types condition)
  (if (condition?* condition)
      (map car (condition-type-field-alist condition))
      '()))

(define (check-condition-type-field-alist the-type-field-alist)
  (let loop ((type-field-alist the-type-field-alist))
    (if (not (null? type-field-alist))
        (let* ((entry (car type-field-alist))
               (type (car entry))
               (field-alist (cdr entry))
               (fields (map car field-alist))
               (all-fields (condition-type-all-fields type)))
          (for-each (lambda (missing-field)
                      (let ((supertype
                             (condition-type-field-supertype type missing-field)))
                        (if (not
                             (any (lambda (entry)
                                    (let ((type (car entry)))
                                      (condition-subtype? type supertype)))
                                  the-type-field-alist))
                            (error "missing field in condition construction"
                                   type
                                   missing-field))))
                    (lset-difference eq? all-fields fields))
          (loop (cdr type-field-alist))))))

(define &condition (really-make-condition-type '&condition
                                               #f
                                               '()
                                               '()))

(define-condition-type &message &condition
  message-condition?
  (message condition-message))

(define-condition-type &serious &condition serious-condition?)

(define-condition-type &error &serious error?)