mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

SRFI-35: Provide nice vtable names, to make GOOPS happier.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2009-10-25 22:57:29 +01:00
parent ef171ff039
commit f9e8030266
2 changed files with 25 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

22
srfi/srfi-35.scm
View file

@ -57,6 +57,19 @@
(number->string (object-address ct) (number->string (object-address ct)
16)))))) 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) (define (condition-type? obj)
"Return true if OBJ is a condition type." "Return true if OBJ is a condition type."
(and (struct? obj) (and (struct? obj)
@ -104,9 +117,7 @@ supertypes."
field-names parent-fields))) field-names parent-fields)))
(let* ((all-fields (append parent-fields field-names)) (let* ((all-fields (append parent-fields field-names))
(layout (struct-layout-for-condition all-fields))) (layout (struct-layout-for-condition all-fields)))
(make-struct %condition-type-vtable 0 (%make-condition-type layout
(make-struct-layout layout) ;; layout
print-condition ;; printer
id parent all-fields)) id parent all-fields))
(error "invalid condition type field names" (error "invalid condition type field names"
field-names))) field-names)))
@ -126,12 +137,9 @@ supertypes."
(let* ((all-fields (append-map condition-type-all-fields (let* ((all-fields (append-map condition-type-all-fields
parents)) parents))
(layout (struct-layout-for-condition all-fields))) (layout (struct-layout-for-condition all-fields)))
(make-struct %condition-type-vtable 0 (%make-condition-type layout
(make-struct-layout layout) ;; layout
print-condition ;; printer
id id
parents ;; list of parents! parents ;; list of parents!
all-fields
all-fields))))) all-fields)))))

8
test-suite/tests/srfi-35.test
View file

@ -1,7 +1,7 @@
;;;; srfi-35.test --- Test suite for SRFI-35 -*- Scheme -*- ;;;; srfi-35.test --- Test suite for SRFI-35 -*- Scheme -*-
;;;; Ludovic Courtès <ludo@gnu.org> ;;;; Ludovic Courtès <ludo@gnu.org>
;;;; ;;;;
;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. ;;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by ;;;; it under the terms of the GNU General Public License as published by
@ -34,7 +34,11 @@
(condition-type? &condition)) (condition-type? &condition))
(pass-if "make-condition-type" (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)))))