From 3bd2f845d9efa342bc656de35eb30163d9f1417f Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
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