scmpkg-exception.stk 4.57 KB
Newer Older
1
;;;;
Erick Gallesio's avatar
Erick Gallesio committed
2
;;;; scmpkg-exception.stk	-- ScmPkg exception implementation
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
;;;; 
;;;; 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)
Erick Gallesio's avatar
Erick Gallesio committed
24
;;;; Last file update: 28-Feb-2007 22:32 (eg)
25 26
;;;;

Erick Gallesio's avatar
Erick Gallesio committed
27

Erick Gallesio's avatar
Erick Gallesio committed
28
(define (%map-scmpkg-exception-on-condition name)
Erick Gallesio's avatar
Erick Gallesio committed
29 30 31 32 33 34 35 36 37
  (case name
    ((@exception)  	      '&@exception)
    ((@error)      	      '&@error)
    ((@io-error)   	      '&@io-error)
    ((@type-error) 	      '&@type-error)
    ((@not-implemented-error) '&@not-implemented-error)
    (else name)))


38 39 40 41 42 43 44 45 46 47 48 49 50
;; ======================================================================
;; 	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
Erick Gallesio's avatar
Erick Gallesio committed
51
					    ,parent
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86
					    ',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)
Erick Gallesio's avatar
Erick Gallesio committed
87
	     (parent '&@exception)
88 89 90 91 92
	     (body body)
	     (fields '()))
    (cond
      ((pair? name)
       (case (length name)
Erick Gallesio's avatar
Erick Gallesio committed
93
	 ((1) (Loop (car name) '&@exception body fields))
Erick Gallesio's avatar
Erick Gallesio committed
94
	 ((2) (Loop (car name) (%map-scmpkg-exception-on-condition (cadr name))
Erick Gallesio's avatar
Erick Gallesio committed
95
		    body fields))
96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
	 (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)
Erick Gallesio's avatar
Erick Gallesio committed
111 112 113 114

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

115
  (let Loop ((args args)
Erick Gallesio's avatar
Erick Gallesio committed
116 117 118 119 120 121
	     (proc #f)
	     (reason #f)
	     (obj #f)
	     (other '()))
   
    (if (null? args)
Erick Gallesio's avatar
Erick Gallesio committed
122
      (let ((name (%map-scmpkg-exception-on-condition name)))
Erick Gallesio's avatar
Erick Gallesio committed
123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140
	`(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)))))))
Erick Gallesio's avatar
Erick Gallesio committed
141 142 143

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