;;; -*- Mode: Scheme; scheme48-package: fasl-conditions -*-

;;;; Fasdumper & Fasloader
;;;; FASL Conditions (SRFI 35)

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define-condition-type &fasdump-condition &condition
  fasdump-condition?
  (port fasdump-condition-port))

(define (with-fasdump-condition-handler handler thunk)
  (with-exception-handler (lambda (condition)
                            (if (fasdump-condition? condition)
                                (handler condition)
                                ;; Argh.  SRFI 34 provides no good way
                                ;; to resignal conditions.
                                (raise condition)))
    thunk))

(define-condition-type &fasl-undumpable &fasdump-condition
  fasl-undumpable?
  (datum fasl-undumpable-datum)
  (encoder-selector fasl-undumpable-encoder-selector))

(define (signal-fasl-undumpable port datum encoder-selector)
  (raise (condition (&fasl-undumpable
                     (port port)
                     (datum datum)
                     (encoder-selector encoder-selector))
                    (&error)
                    (&message (message "datum cannot be fasdumped")))))

(define-condition-type &fasload-condition &condition
  fasload-condition?
  (port fasload-condition-port))

(define (with-fasload-condition-handler handler thunk)
  (with-exception-handler (lambda (condition)
                            (if (fasload-condition? condition)
                                (handler condition)
                                (raise condition)))
    thunk))

(define-condition-type &fasl-incompatibility &fasload-condition
  fasl-incompatibility?
  (min-version fasl-incompatibility-min-version)
  (max-version fasl-incompatibility-max-version)
  (actual-version fasl-incompatibility-actual-version))

(define (signal-fasl-incompatibility port version)
  (raise (condition
          (&fasl-incompatibility
           (port port)
           (min-version fasl-oldest-version)
           (max-version fasl-newest-version)
           (actual-version version))
          (&error)
          (&message
           (message "FASL version out of recognized range")))))

(define-condition-type &malformed-fasl &fasload-condition
  malformed-fasl?)

(define (signal-malformed-fasl port message . irritants)
  (raise (condition (&malformed-fasl (port port))
                    (&error)
                    (&message
                     (message (string-append "malformed FASL: "
                                             message)))
                    (&irritants
                     (values irritants)))))

(define-condition-type &end-of-fasl &fasload-condition
  end-of-fasl?)

(define (signal-end-of-fasl port)       ;** NOT an error.
  (raise (condition (&end-of-fasl (port port)))))

(define (signal-end-of-fasl-error port)
  (raise (condition (&end-of-fasl (port port))
                    (&error)
                    (&message (message "premature end of FASL")))))

(define (with-end-of-fasl-as-error thunk)
  (with-exception-handler (lambda (condition)
                            (if (and (end-of-fasl? condition)
                                     (not (error? condition)))
                                (signal-end-of-fasl-error
                                 (fasload-condition-port condition))
                                (raise condition)))
    thunk))