;;;; conditions.scm
;;;; Kon Lovett, Apr '09

(declare
  (usual-integrations)
  (fixnum)
  (inline)
  (local)
  (no-procedure-checks)
  (no-bound-checks) )

;;;

(module conditions (;export
  make-exn-condition
  make-exn-condition+
  condition-predicate*
  (make-condition-predicate condition-predicate*))

(import scheme chicken (only srfi-1 alist-cons) #;srfi-12)
(require-library srfi-1 #;srfi-12)

;;

(define (make-exn-condition loc msg args)
  (apply make-property-condition
         'exn
         (append (if loc `(location ,loc) '())
                 (if msg `(message ,msg) '())
                 (if (and args (not (null? args))) `(arguments ,args) '()))) )

;; cond:
;; <condition>  ->  <condition>
;; <symbol>     ->  (make-property-condition <symbol>)
;; <pair>       ->  (apply make-property-condition <pair>)
;;   (<symbol> [<symbol> <object>]...)

(define (make-exn-condition+ loc msg args . cnds)
  (apply make-composite-condition
         (make-exn-condition loc msg args)
         (map (lambda (cnd)
                (cond ((condition? cnd)  cnd )
                      ((symbol? cnd)     (make-property-condition cnd) )
                      ((pair? cnd)       (apply make-property-condition cnd) ) ) )
              cnds)) )

;;

(define condition-predicate*
  (let ((preds '()))
    (lambda (tag)
      (let ((cell (assq tag preds)))
        (if cell (cdr cell)
            (let ((pred (condition-predicate tag)))
              (set! preds (alist-cons tag pred preds))
              pred ) ) ) ) ) )

;;

(define-syntax make-condition-predicate
  (syntax-rules ()
    ((_ tag0 ...) (lambda (obj) (and ((condition-predicate* 'tag0) obj) ...) ) ) ) )

) ;module conditions