Hi all, A long time ago, we had a patch that tried to prefix the current module name onto a record type's tag (727b2b3fea271474540f215af4842d32e82e7e6d). This was reverted later on because it turned out to be somewhat incompatible with various things, like the record-variants egg.
I think this is quite an important change which we should try to get in for CHICKEN 5 again, because it's a change that changes fundamentally how record types are tagged. I believe record-variants can be fixed if we also fix #1342 by defining the "type name" which you pass to define-record-type as an identifier. So (define-record foo a) defines foo?, make-foo, foo-a, foo-a-set!, but also just foo. This is apparently a requirement of SRFI-99 and R7RS anyway, and it should also help us to access the tag in record-variants. The attached patch is a fairly straightforward re-application of 727b2b3, with a slightly ore extensive test suite. It also adds the definition of the identifier like I mentioned before. I'd add a patch for record-variants, but I see we have no port to CHICKEN 5 for it yet. In any case, instead of quoting the type name, it would simply be used unquoted, as that's the identifier which holds the tag. I don't know exactly what the problem with coops was, but I presume it was either caused by record-variants not working or we can fix it in a similar way by using the record identifier instead of the quoted tag. There are two remaining questions: - Should the core record types like "promise", "thread" and so on be tagged with a module prefix? I think it's fine to keep them the way they are. - Should the identifier be bound to the raw tag, or should it be wrapped in some kind of opaque object (perhaps a "record type" record type)? Personally, I think it's probably better (and also less confusing to the user) to wrap it, but that's a slightly larger change which can go in later, so I decided to keep this patch simple. Cheers, Peter
From 3bd2f845d9efa342bc656de35eb30163d9f1417f Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Fri, 14 Jul 2017 13:51:24 +0200
Subject: [PATCH] Get rid of "global namespace" for record types.
Before, when define-record-type or define-record were used, the name
that's passed in is taken directly as the tag. Therefore, if two
completely unrelated modules define a record type (with a completely
different layout), both predicates would accept eachother's record
objects. Worse, if an accessor was used on one of them this could
be an unsafe operation resulting in segfaults and other Bad Things.
This restores "applied zbigniew's record-rename patch (finally), added
test-case", which is 727b2b3fea271474540f215af4842d32e82e7e6d.
Thereby, we revert commit 045524a45217ff1eed79a73190d61c561999fba5.
Furthermore, we now expose the "type name" as an identifier which is
bound to the value of the type tag stored in the record. This is a
requirement of both SRFI-99 and R7RS (see #1342), and ensures we can
access the tag of a record type defined in another module. This is
useful for the record-variants egg; it extends existing/predefined
record types with new behaviour, but to do so it needs to be able to
know what the tag is even if the record was defined in another module.
---
NEWS | 5 ++++
chicken-syntax.scm | 61 ++++++++++++++++++++++++++++++++------------
distribution/manifest | 1 +
tests/record-rename-test.scm | 50 ++++++++++++++++++++++++++++++++++++
tests/runtests.bat | 4 +++
tests/runtests.sh | 3 +++
6 files changed, 107 insertions(+), 17 deletions(-)
create mode 100644 tests/record-rename-test.scm
diff --git a/NEWS b/NEWS
index 5db0be65..54d1b404 100644
--- a/NEWS
+++ b/NEWS
@@ -62,6 +62,11 @@
undocumented and not officially supported anyway.
- define and friends are now aggressively rejected in "expression
contexts" (i.e., anywhere but toplevel or as internal defines).
+ - define-record and define-record-type now create record types
+ which are tagged with the module in which they're defined, so
+ predicates no longer return #t for records with the same tag
+ defined in another module. This tag is now also available under
+ an identifier that matches the record type name (fixes #1342).
- Eggs management
- Egg-installation and building has been completely overhauled.
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 7a461726..0f95cd38 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -124,9 +124,14 @@
(##sys#er-transformer
(lambda (x r c)
(##sys#check-syntax 'define-record x '(_ symbol . _))
- (let* ((name (cadr x))
+ (let* ((type-name (cadr x))
+ (plain-name (strip-syntax type-name))
+ (prefix (symbol->string plain-name))
+ (tag (if (##sys#current-module)
+ (symbol-append
+ (##sys#module-name (##sys#current-module)) '|#| plain-name)
+ plain-name))
(slots (cddr x))
- (prefix (symbol->string name))
(%define (r 'define))
(%setter (r 'setter))
(%getter-with-setter (r 'getter-with-setter))
@@ -144,14 +149,15 @@
'define-record "invalid slot specification" slot))))
slots)))
`(##core#begin
+ (,%define ,type-name (##core#quote ,tag))
(,%define
,(string->symbol (string-append "make-" prefix))
(##core#lambda
,slotnames
- (##sys#make-structure (##core#quote ,name) ,@slotnames)))
+ (##sys#make-structure (##core#quote ,tag) ,@slotnames)))
(,%define
,(string->symbol (string-append prefix "?"))
- (##core#lambda (x) (##sys#structure? x ',name)) )
+ (##core#lambda (x) (##sys#structure? x (##core#quote ,tag))) )
,@(let mapslots ((slots slots) (i 1))
(if (eq? slots '())
slots
@@ -163,7 +169,7 @@
(setrcode
`(##core#lambda
(x val)
- (##core#check (##sys#check-structure x (##core#quote ,name)))
+ (##core#check (##sys#check-structure x (##core#quote ,tag)))
(##sys#block-set! x ,i val) ) ))
(cons
`(##core#begin
@@ -176,12 +182,12 @@
`(,%getter-with-setter
(##core#lambda
(x)
- (##core#check (##sys#check-structure x (##core#quote ,name)))
+ (##core#check (##sys#check-structure x (##core#quote ,tag)))
(##sys#block-ref x ,i) )
,setrcode)
`(##core#lambda
(x)
- (##core#check (##sys#check-structure x (##core#quote ,name)))
+ (##core#check (##sys#check-structure x (##core#quote ,tag)))
(##sys#block-ref x ,i) ) ) ) )
(mapslots (##sys#slot slots 1) (fx+ i 1)) ) ) ) ) ) ) ) ) )
@@ -921,12 +927,25 @@
(##sys#check-syntax
'define-record-printer (cons head body)
'((symbol symbol symbol) . #(_ 1)))
- `(##sys#register-record-printer
- ',(##sys#slot head 0)
- (##core#lambda ,(##sys#slot head 1) ,@body)) ]
- [else
+ (let* ((plain-name (strip-syntax (##sys#slot head 0)))
+ (tag (if (##sys#current-module)
+ (symbol-append
+ (##sys#module-name (##sys#current-module))
+ '|#| plain-name)
+ plain-name)))
+ `(##sys#register-record-printer
+ (##core#quote ,tag)
+ (##core#lambda ,(##sys#slot head 1) ,@body))) ]
+ (else
(##sys#check-syntax 'define-record-printer (cons head body) '(symbol _))
- `(##sys#register-record-printer ',head ,@body) ] ) ))))
+ (let* ((plain-name (strip-syntax head))
+ (tag (if (##sys#current-module)
+ (symbol-append
+ (##sys#module-name (##sys#current-module))
+ '|#| plain-name)
+ plain-name)))
+ `(##sys#register-record-printer
+ (##core#quote ,tag) ,@body)) ) ) ))))
;;; SRFI-9:
@@ -939,7 +958,13 @@
'define-record-type
form
'(_ variable #(variable 1) variable . _))
- (let* ((t (cadr form))
+ (let* ((type-name (cadr form))
+ (plain-name (strip-syntax type-name))
+ (tag (if (##sys#current-module)
+ (symbol-append
+ (##sys#module-name (##sys#current-module))
+ '|#| plain-name)
+ plain-name))
(conser (caddr form))
(pred (cadddr form))
(slots (cddddr form))
@@ -950,15 +975,17 @@
(y (r 'y))
(slotnames (map car slots)))
`(##core#begin
+ ;; TODO: Maybe wrap this in an opaque object?
+ (,%define ,type-name (##core#quote ,tag))
(,%define ,conser
(##sys#make-structure
- (##core#quote ,t)
+ (##core#quote ,tag)
,@(map (lambda (sname)
(if (memq sname vars)
sname
'(##core#undefined) ) )
slotnames) ) )
- (,%define (,pred ,x) (##sys#structure? ,x (##core#quote ,t)))
+ (,%define (,pred ,x) (##sys#structure? ,x (##core#quote ,tag)))
,@(let loop ([slots slots] [i 1])
(if (null? slots)
'()
@@ -974,7 +1001,7 @@
(##core#check
(##sys#check-structure
,x
- (##core#quote ,t)
+ (##core#quote ,tag)
(##core#quote ,(cadr slot))))
(##sys#block-ref ,x ,i) ) )
(set (and settable
@@ -983,7 +1010,7 @@
(##core#check
(##sys#check-structure
,x
- (##core#quote ,t)
+ (##core#quote ,tag)
(##core#quote ,ssetter)))
(##sys#block-set! ,x ,i ,y)) )))
`((,%define
diff --git a/distribution/manifest b/distribution/manifest
index fcdc89c7..02bde929 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -129,6 +129,7 @@ tests/linking-tests.scm
tests/compiler-tests.scm
tests/inlining-tests.scm
tests/locative-stress-test.scm
+tests/record-rename-test.scm
tests/r4rstest.scm
tests/null.scm
tests/sgrep.scm
diff --git a/tests/record-rename-test.scm b/tests/record-rename-test.scm
new file mode 100644
index 00000000..96a575d8
--- /dev/null
+++ b/tests/record-rename-test.scm
@@ -0,0 +1,50 @@
+;;;; record-rename-test.scm
+
+
+(define-record foo a)
+
+(define-record-type bar
+ (make-bar x)
+ bar?
+ (x get-x))
+
+
+(module m1 (make-foo make-bar foo? bar?)
+(import scheme chicken)
+
+(define-record foo a b)
+
+(define-record-type bar
+ (make-bar x y)
+ bar?
+ (x get-x) (y get-y))
+
+(let ((f1 (make-foo 1 2))
+ (f2 (make-bar 3 4)))
+ (print "Inside module m1: " (list foo f1 bar f2)))
+)
+
+(define toplevel-foo? foo?)
+(define toplevel-bar? foo?)
+
+(let ((f1 (make-foo 1))
+ (f2 (make-bar 2)))
+ (print "At toplevel before importing m1: " (list foo f1 bar f2))
+ (assert (foo? f1))
+ (assert (not (bar? f1)))
+ (assert (not (foo? f2)))
+ (assert (bar? f2)))
+
+(import m1)
+
+(let ((f1 (make-foo 1 2))
+ (f2 (make-bar 3 4)))
+ (print "At toplevel after importing m1: " (list foo f1 bar f2))
+ (assert (foo? f1))
+ (assert (not (bar? f1)))
+ (assert (not (foo? f2)))
+ (assert (bar? f2))
+ (assert (not (toplevel-foo? f1)))
+ (assert (not (toplevel-bar? f1)))
+ (assert (not (toplevel-foo? f2)))
+ (assert (not (toplevel-bar? f2))))
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 8eb5fea8..e0199cc8 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -463,6 +463,10 @@ echo ======================================== find-files tests ...
%interpret% -bnq test-find-files.scm
if errorlevel 1 exit /b 1
+echo "======================================== record-renaming tests ..."
+%interpret% -bnq record-rename-test.scm
+if errorlevel 1 exit /b 1
+
echo ======================================== regular expression tests ...
%interpret% -bnq test-irregex.scm
if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 7c7507d5..ef2c6def 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -366,6 +366,9 @@ $compile posix-tests.scm
echo "======================================== find-files tests ..."
$interpret -bnq test-find-files.scm
+echo "======================================== record-renaming tests ..."
+$interpret -bnq record-rename-test.scm
+
echo "======================================== regular expression tests ..."
$interpret -bnq test-irregex.scm
$interpret -bnq test-glob.scm
--
2.11.0
signature.asc
Description: PGP signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
