diff options
author | Ludovic Courtès <ludo@gnu.org> | 2009-10-25 22:57:29 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2009-10-25 22:57:29 +0100 |
commit | 5565279a67f9c0da5888273c5904b1b69d021522 (patch) | |
tree | 35897a731179604d551ca792c211a7f22e6f216d | |
parent | 288bbc44cf6f3839331a03649933f25d2361e06f (diff) | |
download | guile-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.scm | 30 | ||||
-rw-r--r-- | test-suite/tests/srfi-35.test | 8 |
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))))) |