diff options
author | Ludovic Courtès <ludo@gnu.org> | 2012-04-10 00:17:39 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2012-04-10 00:17:39 +0200 |
commit | 5ef102cc93a4f2eba0f5dad94a7306085b353000 (patch) | |
tree | 8e68b327167ff1ae24d27ff0c88cff126f806e94 | |
parent | bbb9f000ad52282ee1a0518b65437baf20c3d17c (diff) | |
download | guile-5ef102cc93a4f2eba0f5dad94a7306085b353000.tar.gz |
SRFI-9: Set the `record-constructor' slot of the RTD.
Fixed <http://bugs.gnu.org/11196>.
Reported by Klaus Stehle <klaus.stehle@uni-tuebingen.de>.
* module/srfi/srfi-9.scm (define-record-type): Define the contructor
before TYPE-NAME. Set RTD's constructor field.
* test-suite/tests/srfi-9.test ("record compatibility"): New test
prefix.
-rw-r--r-- | module/srfi/srfi-9.scm | 12 | ||||
-rw-r--r-- | test-suite/tests/srfi-9.test | 11 |
2 files changed, 18 insertions, 5 deletions
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm index cb8dd0a19..da71d1e93 100644 --- a/module/srfi/srfi-9.scm +++ b/module/srfi/srfi-9.scm @@ -1,6 +1,6 @@ ;;; srfi-9.scm --- define-record-type -;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012 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 @@ -188,8 +188,12 @@ (let* ((fields (field-identifiers #'(field-spec ...))) (field-count (length fields)) (layout (string-concatenate (make-list field-count "pw"))) - (indices (field-indices (map syntax->datum fields)))) + (indices (field-indices (map syntax->datum fields))) + (ctor-name (syntax-case #'constructor-spec () + ((ctor args ...) #'ctor)))) #`(begin + #,(constructor #'type-name #'constructor-spec indices) + (define type-name (let ((rtd (make-struct/no-tail record-type-vtable @@ -198,13 +202,13 @@ 'type-name '#,fields))) (set-struct-vtable-name! rtd 'type-name) + (struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name) rtd)) + (define-inlinable (predicate-name obj) (and (struct? obj) (eq? (struct-vtable obj) type-name))) - #,(constructor #'type-name #'constructor-spec indices) - #,@(accessors #'type-name #'(field-spec ...) indices))))))) ;;; srfi-9.scm ends here diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test index f26a7a2cd..321fe16ac 100644 --- a/test-suite/tests/srfi-9.test +++ b/test-suite/tests/srfi-9.test @@ -1,7 +1,7 @@ ;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*- ;;;; Martin Grabmueller, 2001-05-10 ;;;; -;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011, 2012 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 @@ -110,3 +110,12 @@ (let ((frotz (make-frotz 1 2))) (and (= (frotz-a frotz) 1) (= (frotz-b frotz) 2))))) + +(with-test-prefix "record compatibility" + + (pass-if "record?" + (record? (make-foo 1))) + + (pass-if "record-constructor" + (equal? ((record-constructor :foo) 1) + (make-foo 1)))) |