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.

diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index cb8dd0a..da71d1e 100644 (file)
--- 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 f26a7a2..321fe16 100644 (file)
--- 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))))