-;;; srfi-35.scm --- Conditions
+;;; srfi-35.scm --- Conditions -*- coding: utf-8 -*-
-;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+;; 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 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>
+;;; Author: Ludovic Courtès <ludo@gnu.org>
;;; Commentary:
(define-module (srfi srfi-35)
#:use-module (srfi srfi-1)
- #:use-module (ice-9 syncase)
#:export (make-condition-type condition-type?
make-condition condition? condition-has-type? condition-ref
make-compound-condition extract-condition
;; The vtable of all condition types.
;; vtable fields: vtable, self, printer
;; user fields: id, parent, all-field-names
- (make-vtable-vtable "prprpr" 0
- (lambda (ct port)
- (if (eq? ct %condition-type-vtable)
- (display "#<condition-type-vtable>")
- (format port "#<condition-type ~a ~a>"
- (condition-type-id ct)
- (number->string (object-address ct)
- 16))))))
+ (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."
(define (condition-type-id ct)
(and (condition-type? ct)
- (struct-ref ct 3)))
+ (struct-ref ct (+ vtable-offset-user 0))))
(define (condition-type-parent ct)
(and (condition-type? ct)
- (struct-ref ct 4)))
+ (struct-ref ct (+ vtable-offset-user 1))))
(define (condition-type-all-fields ct)
(and (condition-type? ct)
- (struct-ref ct 5)))
+ (struct-ref ct (+ vtable-offset-user 2))))
(define (struct-layout-for-condition field-names)
(cons "pr" layout)))))
(define (print-condition c port)
- (format port "#<condition ~a ~a>"
- (condition-type-id (condition-type c))
- (number->string (object-address c) 16)))
+ ;; 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
field-names parent-fields)))
(let* ((all-fields (append parent-fields field-names))
(layout (struct-layout-for-condition all-fields)))
- (make-struct %condition-type-vtable 0
- (make-struct-layout layout) ;; layout
- print-condition ;; printer
- id parent 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))
(let* ((all-fields (append-map condition-type-all-fields
parents))
(layout (struct-layout-for-condition all-fields)))
- (make-struct %condition-type-vtable 0
- (make-struct-layout layout) ;; layout
- print-condition ;; printer
- id
- parents ;; list of parents!
- all-fields
- all-fields)))))
+ (%make-condition-type layout
+ id
+ parents ;; list of parents!
+ all-fields)))))
\f
;;;
;;; Syntax.
;;;
-(define-syntax define-condition-type
- (syntax-rules ()
- ((_ 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 compound-condition
+(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'.
- (syntax-rules ()
- ((_ (type ...) (field ...))
- (condition ((make-compound-condition-type '%compound `(,type ...))
- field ...)))))
+ (condition ((make-compound-condition-type '%compound `(,type ...))
+ field ...)))
(define-syntax condition-instantiation
;; Build the `(make-condition type ...)' call.
(define-condition-type &error &serious
error?)
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
-
;;; srfi-35.scm ends here
HCoop / bpt / guile.git / blobdiff