summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2009-10-25 22:57:29 +0100
committerLudovic Courtès <ludo@gnu.org>2009-10-25 22:57:29 +0100
commit5565279a67f9c0da5888273c5904b1b69d021522 (patch)
tree35897a731179604d551ca792c211a7f22e6f216d
parent288bbc44cf6f3839331a03649933f25d2361e06f (diff)
downloadguile-5565279a67f9c0da5888273c5904b1b69d021522.tar.gz
SRFI-35: Provide nice vtable names, to make GOOPS happier.
* module/srfi/srfi-35.scm (%make-condition-type): New procedure. (make-condition-type, make-compound-condition-type): Use it. * test-suite/tests/srfi-35.test ("condition types")["struct-vtable-name"]: New test.
-rw-r--r--module/srfi/srfi-35.scm30
-rw-r--r--test-suite/tests/srfi-35.test8
2 files changed, 25 insertions, 13 deletions
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index 1d496fcce..12aa83a8c 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -57,6 +57,19 @@
(number->string (object-address ct)
16))))))
+(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)
@@ -104,10 +117,8 @@ supertypes."
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))
@@ -126,13 +137,10 @@ supertypes."
(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)))))
;;;
diff --git a/test-suite/tests/srfi-35.test b/test-suite/tests/srfi-35.test
index 24ee60248..849d1dea2 100644
--- a/test-suite/tests/srfi-35.test
+++ b/test-suite/tests/srfi-35.test
@@ -1,7 +1,7 @@
;;;; srfi-35.test --- Test suite for SRFI-35 -*- Scheme -*-
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
-;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 2007, 2008, 2009 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
@@ -33,7 +33,11 @@
(condition-type? &condition))
(pass-if "make-condition-type"
- (condition-type? (make-condition-type 'foo &condition '(a b)))))
+ (condition-type? (make-condition-type 'foo &condition '(a b))))
+
+ (pass-if "struct-vtable-name"
+ (let ((ct (make-condition-type 'chbouib &condition '(a b))))
+ (eq? 'chbouib (struct-vtable-name ct)))))