-;;; srfi-35.scm --- Conditions
+;;; srfi-35.scm --- Conditions -*- coding: utf-8 -*-
-;; Copyright (C) 2007, 2008 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 as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
+;; 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
;; 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:
;; 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-macro (define-condition-type name parent pred . field-specs)
- `(begin
- (define ,name
- (make-condition-type ',name ,parent
- ',(map car field-specs)))
- (define (,pred c)
- (condition-has-type? c ,name))
- ,@(map (lambda (field-spec)
- (let ((field-name (car field-spec))
- (accessor (cadr field-spec)))
- `(define (,accessor c)
- (condition-ref c ',field-name))))
- field-specs)))
-
-(define-macro (condition . type-field-bindings)
- (cond ((null? type-field-bindings)
- (error "`condition' syntax error" type-field-bindings))
- (else
- ;; the poor man's hygienic macro
- (let ((mc (gensym "mc"))
- (mcct (gensym "mcct")))
- `(let ((,mc (@ (srfi srfi-35) make-condition))
- (,mcct (@@ (srfi srfi-35) make-compound-condition-type)))
- (,mc (,mcct 'compound (list ,@(map car type-field-bindings)))
- ,@(append-map (lambda (type-field-binding)
- (append-map (lambda (field+value)
- (let ((f (car field+value))
- (v (cadr field+value)))
- `(',f ,v)))
- (cdr type-field-binding)))
- type-field-bindings)))))))
+(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
;;;
(define-condition-type &error &serious
error?)
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
-
;;; srfi-35.scm ends here
HCoop / bpt / guile.git / blobdiff