[bpt/guile.git] / module / srfi / srfi-35.scm

;;; srfi-35.scm --- Conditions                 -*- coding: utf-8 -*-

;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Ludovic Courtès <ludo@gnu.org>

;;; Commentary:

;; This is an implementation of SRFI-35, "Conditions".  Conditions are a
;; means to convey information about exceptional conditions between parts of
;; a program.

;;; Code:

(define-module (srfi srfi-35)
  #:use-module (srfi srfi-1)
  #:export (make-condition-type condition-type?
            make-condition condition? condition-has-type? condition-ref
            make-compound-condition extract-condition
            define-condition-type condition
            &condition
            &message message-condition? condition-message
            &serious serious-condition?
            &error error?))

(cond-expand-provide (current-module) '(srfi-35))

\f
;;;
;;; Condition types.
;;;

(define %condition-type-vtable
  ;; The vtable of all condition types.
  ;;   vtable fields: vtable, self, printer
  ;;   user fields:   id, parent, all-field-names
  (let ((s (make-vtable (string-append standard-vtable-fields "prprpr")
                        (lambda (ct port)
                          (format port "#<condition-type ~a ~a>"
                                  (condition-type-id ct)
                                  (number->string (object-address ct)
                                                  16))))))
    (set-struct-vtable-name! s 'condition-type)
    s))

(define (%make-condition-type layout id parent all-fields)
  (let ((struct (make-struct %condition-type-vtable 0
                             (make-struct-layout layout) ;; layout
                             print-condition             ;; printer
                             id parent all-fields)))

    ;; Hack to associate STRUCT with a name, providing a better name for
    ;; GOOPS classes as returned by `class-of' et al.
    (set-struct-vtable-name! struct (cond ((symbol? id) id)
                                          ((string? id) (string->symbol id))
                                          (else         (string->symbol ""))))
    struct))

(define (condition-type? obj)
  "Return true if OBJ is a condition type."
  (and (struct? obj)
       (eq? (struct-vtable obj)
	    %condition-type-vtable)))

(define (condition-type-id ct)
  (and (condition-type? ct)
       (struct-ref ct (+ vtable-offset-user 0))))

(define (condition-type-parent ct)
  (and (condition-type? ct)
       (struct-ref ct (+ vtable-offset-user 1))))

(define (condition-type-all-fields ct)
  (and (condition-type? ct)
       (struct-ref ct (+ vtable-offset-user 2))))


(define (struct-layout-for-condition field-names)
  ;; Return a string denoting the layout required to hold the fields listed
  ;; in FIELD-NAMES.
  (let loop ((field-names field-names)
	     (layout      '("pr")))
    (if (null? field-names)
	(string-concatenate/shared layout)
	(loop (cdr field-names)
	      (cons "pr" layout)))))

(define (print-condition c port)
  ;; Print condition C to PORT in a way similar to how records print:
  ;; #<condition TYPE [FIELD: VALUE ...] ADDRESS>.
  (define (field-values)
    (let* ((type    (struct-vtable c))
           (strings (fold (lambda (field result)
                            (cons (format #f "~A: ~S" field
                                          (condition-ref c field))
                                  result))
                          '()
                          (condition-type-all-fields type))))
      (string-join (reverse strings) " ")))

  (format port "#<condition ~a [~a] ~a>"
          (condition-type-id (condition-type c))
          (field-values)
          (number->string (object-address c) 16)))

(define (make-condition-type id parent field-names)
  "Return a new condition type named ID, inheriting from PARENT, and with the
fields whose names are listed in FIELD-NAMES.  FIELD-NAMES must be a list of
symbols and must not contain names already used by PARENT or one of its
supertypes."
  (if (symbol? id)
      (if (condition-type? parent)
	  (let ((parent-fields (condition-type-all-fields parent)))
	    (if (and (every symbol? field-names)
		     (null? (lset-intersection eq?
					       field-names parent-fields)))
		(let* ((all-fields (append parent-fields field-names))
		       (layout     (struct-layout-for-condition all-fields)))
		  (%make-condition-type layout
                                        id parent all-fields))
		(error "invalid condition type field names"
		       field-names)))
	  (error "parent is not a condition type" parent))
      (error "condition type identifier is not a symbol" id)))

(define (make-compound-condition-type id parents)
  ;; Return a compound condition type made of the types listed in PARENTS.
  ;; All fields from PARENTS are kept, even same-named ones, since they are
  ;; needed by `extract-condition'.
  (cond ((null? parents)
         (error "`make-compound-condition-type' passed empty parent list"
                id))
        ((null? (cdr parents))
         (car parents))
        (else
         (let* ((all-fields (append-map condition-type-all-fields
                                        parents))
                (layout     (struct-layout-for-condition all-fields)))
           (%make-condition-type layout
                                 id
                                 parents         ;; list of parents!
                                 all-fields)))))

\f
;;;
;;; Conditions.
;;;

(define (condition? c)
  "Return true if C is a condition."
  (and (struct? c)
       (condition-type? (struct-vtable c))))

(define (condition-type c)
  (and (struct? c)
       (let ((vtable (struct-vtable c)))
	 (if (condition-type? vtable)
	     vtable
	     #f))))

(define (condition-has-type? c type)
  "Return true if condition C has type TYPE."
  (if (and (condition? c) (condition-type? type))
      (let loop ((ct (condition-type c)))
        (or (eq? ct type)
            (and ct
                 (let ((parent (condition-type-parent ct)))
                   (if (list? parent)
                       (any loop parent) ;; compound condition
                       (loop (condition-type-parent ct)))))))
      (throw 'wrong-type-arg "condition-has-type?"
             "Wrong type argument")))

(define (condition-ref c field-name)
  "Return the value of the field named FIELD-NAME from condition C."
  (if (condition? c)
      (if (symbol? field-name)
	  (let* ((type   (condition-type c))
		 (fields (condition-type-all-fields type))
		 (index  (list-index (lambda (name)
				       (eq? name field-name))
				     fields)))
	    (if index
		(struct-ref c index)
		(error "invalid field name" field-name)))
	  (error "field name is not a symbol" field-name))
      (throw 'wrong-type-arg "condition-ref"
             "Wrong type argument: ~S" c)))

(define (make-condition-from-values type values)
  (apply make-struct type 0 values))

(define (make-condition type . field+value)
  "Return a new condition of type TYPE with fields initialized as specified
by FIELD+VALUE, a sequence of field names (symbols) and values."
  (if (condition-type? type)
      (let* ((all-fields (condition-type-all-fields type))
	     (inits      (fold-right (lambda (field inits)
				       (let ((v (memq field field+value)))
					 (if (pair? v)
					     (cons (cadr v) inits)
					     (error "field not specified"
						    field))))
				     '()
				     all-fields)))
	(make-condition-from-values type inits))
      (throw 'wrong-type-arg "make-condition"
             "Wrong type argument: ~S" type)))

(define (make-compound-condition . conditions)
  "Return a new compound condition composed of CONDITIONS."
  (let* ((types  (map condition-type conditions))
	 (ct     (make-compound-condition-type 'compound types))
	 (inits  (append-map (lambda (c)
			       (let ((ct (condition-type c)))
				 (map (lambda (f)
					(condition-ref c f))
				      (condition-type-all-fields ct))))
			     conditions)))
    (make-condition-from-values ct inits)))

(define (extract-condition c type)
  "Return a condition of condition type TYPE with the field values specified
by C."

  (define (first-field-index parents)
    ;; Return the index of the first field of TYPE within C.
    (let loop ((parents parents)
	       (index   0))
      (let ((parent (car parents)))
	(cond ((null? parents)
	       #f)
	      ((eq? parent type)
	       index)
	      ((pair? parent)
	       (or (loop parent index)
		   (loop (cdr parents)
			 (+ index
			    (apply + (map condition-type-all-fields
					  parent))))))
	      (else
	       (let ((shift (length (condition-type-all-fields parent))))
		 (loop (cdr parents)
		       (+ index shift))))))))

  (define (list-fields start-index field-names)
    ;; Return a list of the form `(FIELD-NAME VALUE...)'.
    (let loop ((index       start-index)
	       (field-names field-names)
	       (result      '()))
      (if (null? field-names)
	  (reverse! result)
	  (loop (+ 1 index)
		(cdr field-names)
		(cons* (struct-ref c index)
		       (car field-names)
		       result)))))

  (if (and (condition? c) (condition-type? type))
      (let* ((ct     (condition-type c))
             (parent (condition-type-parent ct)))
        (cond ((eq? type ct)
               c)
              ((pair? parent)
               ;; C is a compound condition.
               (let ((field-index (first-field-index parent)))
                 ;;(format #t "field-index: ~a ~a~%" field-index
                 ;;        (list-fields field-index
                 ;;                     (condition-type-all-fields type)))
                 (apply make-condition type
                        (list-fields field-index
                                     (condition-type-all-fields type)))))
              (else
               ;; C does not have type TYPE.
               #f)))
      (throw 'wrong-type-arg "extract-condition"
             "Wrong type argument")))

\f
;;;
;;; Syntax.
;;;

(define-syntax-rule (define-condition-type name parent pred (field-name field-accessor) ...)
  (begin
    (define name
      (make-condition-type 'name parent '(field-name ...)))
    (define (pred c)
      (condition-has-type? c name))
    (define (field-accessor c)
      (condition-ref c 'field-name))
    ...))

(define-syntax-rule (compound-condition (type ...) (field ...))
  ;; Create a compound condition using `make-compound-condition-type'.
  (condition ((make-compound-condition-type '%compound `(,type ...))
              field ...)))

(define-syntax condition-instantiation
  ;; Build the `(make-condition type ...)' call.
  (syntax-rules ()
    ((_ type (out ...))
     (make-condition type out ...))
    ((_ type (out ...) (field-name field-value) rest ...)
     (condition-instantiation type (out ... 'field-name field-value) rest ...))))

(define-syntax condition
  (syntax-rules ()
    ((_ (type field ...))
     (condition-instantiation type () field ...))
    ((_ (type field ...) ...)
     (compound-condition (type ...) (field ... ...)))))

\f
;;;
;;; Standard condition types.
;;;

(define &condition
  ;; The root condition type.
  (make-struct %condition-type-vtable 0
	       (make-struct-layout "")
	       (lambda (c port)
		 (display "<&condition>"))
	       '&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?)

;;; srfi-35.scm ends here
Commit	Line	Data
bce5cb56	1	;;; srfi-35.scm --- Conditions -- coding: utf-8 --
c9de3d45	2
0c65f52c	3	;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
c9de3d45 LC	4	;;
	5	;; This library is free software; you can redistribute it and/or
	6	;; modify it under the terms of the GNU Lesser General Public
	7	;; License as published by the Free Software Foundation; either
83ba2d37	8	;; version 3 of the License, or (at your option) any later version.
c9de3d45 LC	9	;;
	10	;; This library is distributed in the hope that it will be useful,
	11	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;; Lesser General Public License for more details.
	14	;;
	15	;; You should have received a copy of the GNU Lesser General Public
	16	;; License along with this library; if not, write to the Free Software
	17	;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
	18
bce5cb56	19	;;; Author: Ludovic Courtès <ludo@gnu.org>
c9de3d45 LC	20
	21	;;; Commentary:
	22
	23	;; This is an implementation of SRFI-35, "Conditions". Conditions are a
	24	;; means to convey information about exceptional conditions between parts of
	25	;; a program.
	26
	27	;;; Code:
	28
	29	(define-module (srfi srfi-35)
	30	#:use-module (srfi srfi-1)
	31	#:export (make-condition-type condition-type?
	32	make-condition condition? condition-has-type? condition-ref
	33	make-compound-condition extract-condition
	34	define-condition-type condition
	35	&condition
	36	&message message-condition? condition-message
	37	&serious serious-condition?
	38	&error error?))
	39
816e3edf LC	40	(cond-expand-provide (current-module) '(srfi-35))
816e3edf LC	41
c9de3d45 LC	42	\f
	43	;;;
	44	;;; Condition types.
	45	;;;
	46
	47	(define %condition-type-vtable
	48	;; The vtable of all condition types.
	49	;; vtable fields: vtable, self, printer
	50	;; user fields: id, parent, all-field-names
5139b7b9 AW	51	(let ((s (make-vtable (string-append standard-vtable-fields "prprpr")
	52	(lambda (ct port)
	53	(format port "#<condition-type ~a ~a>"
	54	(condition-type-id ct)
	55	(number->string (object-address ct)
	56	16))))))
	57	(set-struct-vtable-name! s 'condition-type)
	58	s))
c9de3d45	59
5565279a LC	60	(define (%make-condition-type layout id parent all-fields)
	61	(let ((struct (make-struct %condition-type-vtable 0
	62	(make-struct-layout layout) ;; layout
	63	print-condition ;; printer
	64	id parent all-fields)))
	65
	66	;; Hack to associate STRUCT with a name, providing a better name for
	67	;; GOOPS classes as returned by `class-of' et al.
	68	(set-struct-vtable-name! struct (cond ((symbol? id) id)
	69	((string? id) (string->symbol id))
	70	(else (string->symbol ""))))
	71	struct))
	72
c9de3d45 LC	73	(define (condition-type? obj)
	74	"Return true if OBJ is a condition type."
	75	(and (struct? obj)
	76	(eq? (struct-vtable obj)
	77	%condition-type-vtable)))
	78
	79	(define (condition-type-id ct)
	80	(and (condition-type? ct)
ceedcfaa	81	(struct-ref ct (+ vtable-offset-user 0))))
c9de3d45 LC	82
	83	(define (condition-type-parent ct)
	84	(and (condition-type? ct)
ceedcfaa	85	(struct-ref ct (+ vtable-offset-user 1))))
c9de3d45 LC	86
	87	(define (condition-type-all-fields ct)
	88	(and (condition-type? ct)
ceedcfaa	89	(struct-ref ct (+ vtable-offset-user 2))))
c9de3d45 LC	90
	91
	92	(define (struct-layout-for-condition field-names)
	93	;; Return a string denoting the layout required to hold the fields listed
	94	;; in FIELD-NAMES.
	95	(let loop ((field-names field-names)
	96	(layout '("pr")))
	97	(if (null? field-names)
	98	(string-concatenate/shared layout)
	99	(loop (cdr field-names)
	100	(cons "pr" layout)))))
	101
	102	(define (print-condition c port)
67231cef LC	103	;; Print condition C to PORT in a way similar to how records print:
	104	;; #<condition TYPE [FIELD: VALUE ...] ADDRESS>.
	105	(define (field-values)
	106	(let* ((type (struct-vtable c))
	107	(strings (fold (lambda (field result)
	108	(cons (format #f "~A: ~S" field
	109	(condition-ref c field))
	110	result))
	111	'()
	112	(condition-type-all-fields type))))
	113	(string-join (reverse strings) " ")))
	114
	115	(format port "#<condition ~a [~a] ~a>"
	116	(condition-type-id (condition-type c))
	117	(field-values)
	118	(number->string (object-address c) 16)))
c9de3d45 LC	119
	120	(define (make-condition-type id parent field-names)
	121	"Return a new condition type named ID, inheriting from PARENT, and with the
	122	fields whose names are listed in FIELD-NAMES. FIELD-NAMES must be a list of
	123	symbols and must not contain names already used by PARENT or one of its
	124	supertypes."
	125	(if (symbol? id)
	126	(if (condition-type? parent)
	127	(let ((parent-fields (condition-type-all-fields parent)))
	128	(if (and (every symbol? field-names)
	129	(null? (lset-intersection eq?
	130	field-names parent-fields)))
	131	(let* ((all-fields (append parent-fields field-names))
	132	(layout (struct-layout-for-condition all-fields)))
5565279a LC	133	(%make-condition-type layout
5565279a LC	134	id parent all-fields))
c9de3d45 LC	135	(error "invalid condition type field names"
	136	field-names)))
	137	(error "parent is not a condition type" parent))
	138	(error "condition type identifier is not a symbol" id)))
	139
	140	(define (make-compound-condition-type id parents)
	141	;; Return a compound condition type made of the types listed in PARENTS.
	142	;; All fields from PARENTS are kept, even same-named ones, since they are
	143	;; needed by `extract-condition'.
bc4ee34e LC	144	(cond ((null? parents)
	145	(error "`make-compound-condition-type' passed empty parent list"
	146	id))
	147	((null? (cdr parents))
	148	(car parents))
	149	(else
	150	(let* ((all-fields (append-map condition-type-all-fields
	151	parents))
	152	(layout (struct-layout-for-condition all-fields)))
5565279a LC	153	(%make-condition-type layout
	154	id
	155	parents ;; list of parents!
	156	all-fields)))))
c9de3d45 LC	157
	158	\f
	159	;;;
	160	;;; Conditions.
	161	;;;
	162
	163	(define (condition? c)
	164	"Return true if C is a condition."
	165	(and (struct? c)
	166	(condition-type? (struct-vtable c))))
	167
	168	(define (condition-type c)
	169	(and (struct? c)
	170	(let ((vtable (struct-vtable c)))
	171	(if (condition-type? vtable)
	172	vtable
	173	#f))))
	174
	175	(define (condition-has-type? c type)
	176	"Return true if condition C has type TYPE."
	177	(if (and (condition? c) (condition-type? type))
	178	(let loop ((ct (condition-type c)))
	179	(or (eq? ct type)
	180	(and ct
	181	(let ((parent (condition-type-parent ct)))
	182	(if (list? parent)
	183	(any loop parent) ;; compound condition
	184	(loop (condition-type-parent ct)))))))
	185	(throw 'wrong-type-arg "condition-has-type?"
	186	"Wrong type argument")))
	187
	188	(define (condition-ref c field-name)
	189	"Return the value of the field named FIELD-NAME from condition C."
	190	(if (condition? c)
	191	(if (symbol? field-name)
	192	(let* ((type (condition-type c))
	193	(fields (condition-type-all-fields type))
	194	(index (list-index (lambda (name)
	195	(eq? name field-name))
	196	fields)))
	197	(if index
	198	(struct-ref c index)
	199	(error "invalid field name" field-name)))
	200	(error "field name is not a symbol" field-name))
	201	(throw 'wrong-type-arg "condition-ref"
	202	"Wrong type argument: ~S" c)))
	203
	204	(define (make-condition-from-values type values)
	205	(apply make-struct type 0 values))
	206
	207	(define (make-condition type . field+value)
	208	"Return a new condition of type TYPE with fields initialized as specified
	209	by FIELD+VALUE, a sequence of field names (symbols) and values."
	210	(if (condition-type? type)
	211	(let* ((all-fields (condition-type-all-fields type))
	212	(inits (fold-right (lambda (field inits)
	213	(let ((v (memq field field+value)))
	214	(if (pair? v)
	215	(cons (cadr v) inits)
	216	(error "field not specified"
	217	field))))
	218	'()
	219	all-fields)))
	220	(make-condition-from-values type inits))
221	(throw 'wrong-type-arg "make-condition"
222	"Wrong type argument: ~S" type)))
223
224	(define (make-compound-condition . conditions)
225	"Return a new compound condition composed of CONDITIONS."
226	(let* ((types (map condition-type conditions))
227	(ct (make-compound-condition-type 'compound types))
228	(inits (append-map (lambda (c)
229	(let ((ct (condition-type c)))
230	(map (lambda (f)
231	(condition-ref c f))
232	(condition-type-all-fields ct))))
233	conditions)))
234	(make-condition-from-values ct inits)))
235
236	(define (extract-condition c type)
237	"Return a condition of condition type TYPE with the field values specified
238	by C."
239
240	(define (first-field-index parents)
241	;; Return the index of the first field of TYPE within C.
242	(let loop ((parents parents)
243	(index 0))
244	(let ((parent (car parents)))
245	(cond ((null? parents)
246	#f)
247	((eq? parent type)
248	index)
249	((pair? parent)
250	(or (loop parent index)
251	(loop (cdr parents)
252	(+ index
253	(apply + (map condition-type-all-fields
254	parent))))))
255	(else
256	(let ((shift (length (condition-type-all-fields parent))))
257	(loop (cdr parents)
258	(+ index shift))))))))
259
260	(define (list-fields start-index field-names)
261	;; Return a list of the form `(FIELD-NAME VALUE...)'.
262	(let loop ((index start-index)
263	(field-names field-names)
264	(result '()))
265	(if (null? field-names)
266	(reverse! result)
267	(loop (+ 1 index)
268	(cdr field-names)
269	(cons* (struct-ref c index)
270	(car field-names)
271	result)))))
272
273	(if (and (condition? c) (condition-type? type))
274	(let* ((ct (condition-type c))
275	(parent (condition-type-parent ct)))
276	(cond ((eq? type ct)
277	c)
278	((pair? parent)
279	;; C is a compound condition.
280	(let ((field-index (first-field-index parent)))
281	;;(format #t "field-index: ~a ~a~%" field-index
282	;; (list-fields field-index
283	;; (condition-type-all-fields type)))
284	(apply make-condition type
285	(list-fields field-index
286	(condition-type-all-fields type)))))
287	(else
288	;; C does not have type TYPE.
289	#f)))
290	(throw 'wrong-type-arg "extract-condition"
291	"Wrong type argument")))
292
293	\f
294	;;;
295	;;; Syntax.
296	;;;
297
0c65f52c AW	298	(define-syntax-rule (define-condition-type name parent pred (field-name field-accessor) ...)
	299	(begin
	300	(define name
	301	(make-condition-type 'name parent '(field-name ...)))
	302	(define (pred c)
	303	(condition-has-type? c name))
	304	(define (field-accessor c)
	305	(condition-ref c 'field-name))
	306	...))
	307
	308	(define-syntax-rule (compound-condition (type ...) (field ...))
de784acd	309	;; Create a compound condition using `make-compound-condition-type'.
0c65f52c AW	310	(condition ((make-compound-condition-type '%compound `(,type ...))
0c65f52c AW	311	field ...)))
de784acd LC	312
	313	(define-syntax condition-instantiation
	314	;; Build the `(make-condition type ...)' call.
	315	(syntax-rules ()
	316	((_ type (out ...))
	317	(make-condition type out ...))
	318	((_ type (out ...) (field-name field-value) rest ...)
	319	(condition-instantiation type (out ... 'field-name field-value) rest ...))))
	320
	321	(define-syntax condition
	322	(syntax-rules ()
	323	((_ (type field ...))
	324	(condition-instantiation type () field ...))
	325	((_ (type field ...) ...)
	326	(compound-condition (type ...) (field ... ...)))))
c9de3d45 LC	327
	328	\f
	329	;;;
	330	;;; Standard condition types.
	331	;;;
	332
	333	(define &condition
	334	;; The root condition type.
	335	(make-struct %condition-type-vtable 0
	336	(make-struct-layout "")
	337	(lambda (c port)
	338	(display "<&condition>"))
	339	'&condition #f '() '()))
	340
	341	(define-condition-type &message &condition
	342	message-condition?
	343	(message condition-message))
	344
	345	(define-condition-type &serious &condition
	346	serious-condition?)
	347
	348	(define-condition-type &error &serious
	349	error?)
	350
c9de3d45	351	;;; srfi-35.scm ends here