;;;;
;;;; scmpkg-exception.stk	-- ScmPkg exception implementation
;;;; 
;;;; Copyright © 2006-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;; 
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 
;;;; USA.
;;;; 
;;;;           Author: Erick Gallesio [eg@essi.fr]
;;;;    Creation date: 15-Dec-2006 15:15 (eg)
;;;; Last file update: 28-Feb-2007 22:32 (eg)
;;;;


(define (%map-scmpkg-exception-on-condition name)
  (case name
    ((@exception)  	      '&@exception)
    ((@error)      	      '&@error)
    ((@io-error)   	      '&@io-error)
    ((@type-error) 	      '&@type-error)
    ((@not-implemented-error) '&@not-implemented-error)
    (else name)))


;; ======================================================================
;; 	define-exception
;; ======================================================================
(define-macro (define-scmpkg-exception name . body)

  (define (%define-exception->condition name parent slots)
    (let ((pred    (string->symbol (format "~a?" name)))
	  (constr  (string->symbol (format "make-~a" name)))
	  (arg     (gensym))
	  (val     (gensym)))
      `(begin
	 ;; Build the condition
	 (define ,name (make-condition-type ',name
					    ,parent
					    ',slots))
	 
         ;; Build the predicate
	 (define (,pred ,arg)
	   (and (condition? ,arg) (condition-has-type? ,arg ,name)))
	 
	 ;; Export name constructor and predicate
	 (export ,name ,constr ,pred)
	 
	 ;; Build the readers and setters
	 (let ((module (current-module)))
	   (for-each (lambda (x)
		       (let ((reader (string->symbol (format "~a-~a" ',name x)))
			     (writer (string->symbol (format "~a-~a-set!"
							     ',name x))))
			 ;; reader
			 (%symbol-define reader
					 (lambda(,arg)
					   (condition-ref ,arg x x))
					 module)
			 ;; writer
			 (%symbol-define writer
					 (lambda (,arg ,val)
					   (condition-set! ,arg x ,val))
					 module)
			 ;; export reader and writer
			 (%module-export  module (list reader writer))))
		     (struct-type-slots ,name)))
	 
	 ;; Build the toplevel result
	 (values (void) ',name))))
  ;;
  ;; body of define-exception*
  ;;  
  (let Loop ((name name)
	     (parent '&@exception)
	     (body body)
	     (fields '()))
    (cond
      ((pair? name)
       (case (length name)
	 ((1) (Loop (car name) '&@exception body fields))
	 ((2) (Loop (car name) (%map-scmpkg-exception-on-condition (cadr name))
		    body fields))
	 (else (error "bad exception name ~S" name))))
      ((null? body)
       (%define-exception->condition name parent (reverse! fields)))
      ((symbol? (car body))
       (Loop name 
	     parent
	     (cdr body)
	     (cons (car body) fields)))
      (else
       (error "bad exception field expected ~S" (car body))))))

;; ======================================================================
;; 	exception
;; ======================================================================
(define-macro (exception name . args)

  (define (valid-keyword? key)
    (or (keyword? key) (memq key '(?proc ?reason ?obj))))

  (let Loop ((args args)
	     (proc #f)
	     (reason #f)
	     (obj #f)
	     (other '()))
   
    (if (null? args)
      (let ((name (%map-scmpkg-exception-on-condition name)))
	`(make-condition ,name
			 'backtrace '()
			 'location ',(or proc name)
			 'message (string-append (or ,reason "")
						 (if ,obj (format " ~s" ,obj) ""))
			 ,@other))
      (let ((key (car args)))
	(if (and (valid-keyword? key) (not (null? (cdr args))))
	  (case key
	    ((?proc)   (Loop (cddr args) (cadr args) reason obj other))
	    ((?reason) (Loop (cddr args) proc (cadr args) obj other))
	    ((?obj)    (Loop (cddr args) proc reason (cadr args) other))
	    (else      (Loop (cddr args) proc reason obj
			     (append!
			      other
			      `(',(string->symbol (keyword->string (car args)))
				,(cadr args))))))
	  (error "bad keyword ~S" (car args)))))))

;; ======================================================================
(export %map-scmpkg-exception-on-condition)