mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

SRFI-9: Set the `record-constructor' slot of the RTD.

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2012-04-10 00:17:39 +02:00
parent bbb9f000ad
commit 5ef102cc93
2 changed files with 18 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

12
module/srfi/srfi-9.scm
View file

@ -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

11
test-suite/tests/srfi-9.test
View file

@ -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))))