unofficial mirror of bug-guile@gnu.org 
 help / color / mirror / Atom feed
* r6rs define-record-type is unhygienic
@ 2011-06-11 13:36 Ian Price
  2011-06-17  8:34 ` Andy Wingo
  0 siblings, 1 reply; 4+ messages in thread
From: Ian Price @ 2011-06-11 13:36 UTC (permalink / raw)
  To: bug-guile

[-- Attachment #1: Type: text/plain, Size: 2731 bytes --]


Hello Guilers,

Yesterday, I posted this example on IRC

;;; type.scm
#!r6rs
(library (type)
(export define-type)
(import (rnrs))

(define-syntax define-type
  (lambda (stx)
    (syntax-case stx ()
      [(define-type type-id (field guard) ...)
       #'(begin
           (assert (symbol? 'type-id))
           (display "yep\n")
           (define-record-type type-id
             (protocol
              (lambda (x)
                (lambda (field ...)
                  (assert (guard field)) ...
                  (x field ...))))
             (fields field ...)))])))
)
;;; foo.scm
(import (type))
;; not importing (rnrs), because it would hide the bug
(define true (lambda _ #t))

(define-type kons (kar true) (kdr true))

(define k1 (make-kons 3 4))
(write k1)


I expected this to print

yep
#<r6rs:record:kons>

but instead I get

yep
Backtrace:
In module/ice−9/boot−9.scm:
 170: 8 [catch #t #<catch−closure a250ed0> ...]
In unknown file:
   ?: 7 [catch−closure]
In module/ice−9/boot−9.scm:
  62: 6 [call−with−prompt prompt0 ...]
In module/ice−9/eval.scm:
 389: 5 [eval # #]
In module/ice−9/boot−9.scm:
2103: 4 [save−module−excursion #<procedure a263ce0 at module/ice−9/boot−9.scm:3528:3 ()>]
3535: 3 [#<procedure a263ce0 at module/ice−9/boot−9.scm:3528:3 ()>]
In unknown file:
   ?: 2 [load−compiled/vm "/home/Ian/src/guile/cache/guile/ccache/2.0−LE−4−2.0/tmp/foo.scm.go"]
In tmp/foo.scm:
   6: 1 [#<procedure a5e1a30 ()>]
In unknown file:
   ?: 0 [#<procedure a5e1790 (kar kdr)> 3 4]

ERROR: In procedure #<procedure a5e1790 (kar kdr)>:
ERROR: In procedure module−lookup: Unbound variable: assert


As you can see, it claims that 'assert' is unbound, but 'yep' gets
printed, so the first assert must have been successful (and so must have
been bound). Therefore, I came to the conclusion that the protocol
expression was not evaluated in the same environment as the define-type
macro, but instead the environment of the use i.e. it is non-hygienic.

Another example is

(let ((immutable #f))
  (define-record-type foo (fields (immutable bar)))
  #t)


This should be a syntax error as immutable does not have the same
binding as it does in the definition of define-record-type, and
therefore we have an invalid field spec, but in guile it is evaluated to
#t.

I have attached a patch for stable-2.0 to deal with these
issues. Keywords are now matched as syntax-case literals, and
sub-expressions are de-structured as necessary, rather than by using
syntax->datum on all the clauses at the start. There are some issues I
didn't touch, e.g. I think that the error messages should be improved,
but I can do that too if you would like.

If there are any problems let me know,
Ian


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Record hygiene patch --]
[-- Type: text/x-patch, Size: 16238 bytes --]

From 05dcbb4625dfaf38209292430096881fc00d6c68 Mon Sep 17 00:00:00 2001
From: Ian Price <ianprice90@googlemail.com>
Date: Sat, 11 Jun 2011 02:43:08 +0100
Subject: [PATCH] Fix hygiene issues with `define-record-type'

* module/rnrs/records/syntactic.scm(define-record-type0, process-fields):
  Preserve hygiene of record clauses.

* test-suite/tests/r6rs-records-syntactic.test("record hygiene"): Add tests.
---
 module/rnrs/records/syntactic.scm            |  284 ++++++++++++--------------
 test-suite/tests/r6rs-records-syntactic.test |   34 +++
 2 files changed, 166 insertions(+), 152 deletions(-)

diff --git a/module/rnrs/records/syntactic.scm b/module/rnrs/records/syntactic.scm
index 6431fcf..6e57c22 100644
--- a/module/rnrs/records/syntactic.scm
+++ b/module/rnrs/records/syntactic.scm
@@ -75,172 +75,152 @@
     (number-fields-inner fields 0))
   
   (define (process-fields record-name fields)
-    (define record-name-str (symbol->string record-name))
+    (define (wrap x) (datum->syntax record-name x))
+    (define (id->string x)
+      (symbol->string (syntax->datum x)))
+    (define record-name-str (id->string record-name))
     (define (guess-accessor-name field-name)
-      (string->symbol (string-append 
-		       record-name-str "-" (symbol->string field-name))))
+      (wrap
+       (string->symbol (string-append
+                        record-name-str "-" (id->string field-name)))))
     (define (guess-mutator-name field-name)
-      (string->symbol 
-       (string-append 
-	record-name-str "-" (symbol->string field-name) "-set!")))
-    
+      (wrap
+       (string->symbol
+        (string-append
+         record-name-str "-" (id->string field-name) "-set!"))))
     (define (f x)
-      (define (lose)
-        (syntax-violation 'define-record-type "invalid field specifier" x))
-      (cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f))
-	    ((not (list? x)) (lose))
-	    ((eq? (car x) 'immutable)
-	     (cons 'immutable
-		   (case (length x)
-		     ((2) (list (cadr x) (guess-accessor-name (cadr x)) #f))
-		     ((3) (list (cadr x) (caddr x) #f))
-		     (else (lose)))))
-	    ((eq? (car x) 'mutable)
-	     (cons 'mutable
-		   (case (length x)
-		     ((2) (list (cadr x) 
-				(guess-accessor-name (cadr x))
-				(guess-mutator-name (cadr x))))
-		     ((4) (cdr x))
-		     (else (lose)))))
-	    (else (lose))))
+      (syntax-case x (immutable mutable)
+        [(immutable name)
+         (list (wrap `(immutable ,(syntax->datum #'name))) (guess-accessor-name #'name) #f)]
+        [(immutable name accessor)
+         (list (wrap `(immutable ,(syntax->datum #'name))) #'accessor #f)]
+        [(mutable name)
+         (list (wrap `(mutable ,(syntax->datum #'name)))
+               (guess-accessor-name #'name)
+               (guess-mutator-name #'name))]
+        [(mutable name accessor mutator)
+         (list (wrap `(mutable ,(syntax->datum #'name))) #'accessor #'mutator)]
+        [name
+         (identifier? #'name)
+         (list (wrap `(immutable ,(syntax->datum #'name))) (guess-accessor-name #'name) #f)]
+        [else
+         (syntax-violation 'define-record-type "invalid field specifier" x)]))
     (map f fields))
   
   (define-syntax define-record-type0
     (lambda (stx)	  
       (syntax-case stx ()
-	((_ (record-name constructor-name predicate-name) record-clause ...)
-	 (let loop ((fields *unspecified*)
-		    (parent *unspecified*)
-		    (protocol *unspecified*)
-		    (sealed *unspecified*)
-		    (opaque *unspecified*)
-		    (nongenerative *unspecified*)
-		    (constructor *unspecified*)
-		    (parent-rtd *unspecified*)
-		    (record-clauses (syntax->datum #'(record-clause ...))))
-	   (if (null? record-clauses)
-	       (let*
-		((fields (if (unspecified? fields) '() fields))
-		 (field-names
-		  (datum->syntax 
-		   #'record-name
-		   (list->vector (map (lambda (x) (take x 2)) fields))))
-		 (field-accessors
-		  (fold-left (lambda (x c lst) 
-			       (cons #`(define #,(datum->syntax 
-						  #'record-name (caddr x))
-					 (record-accessor record-name #,c))
-				     lst))
-			     '() fields (sequence (length fields))))
-		 (field-mutators
-		  (fold-left (lambda (x c lst) 
-			       (if (cadddr x)
-				   (cons #`(define #,(datum->syntax 
-						      #'record-name (cadddr x))
-					     (record-mutator record-name #,c))
-					 lst)
-				   lst))
-			     '() fields (sequence (length fields))))
-
-		 (parent-cd 
-		  (datum->syntax
-		   stx (cond ((not (unspecified? parent))
-			      `(record-constructor-descriptor ,parent))
-			     ((not (unspecified? parent-rtd)) (cadr parent-rtd))
-			     (else #f))))
-		 (parent-rtd
-		  (datum->syntax 
-		   stx (cond ((not (unspecified? parent))
-			      `(record-type-descriptor ,parent))
-			     ((not (unspecified? parent-rtd)) (car parent-rtd))
-			     (else #f))))
-
-		 (protocol (datum->syntax
-			    #'record-name (if (unspecified? protocol) 
-					      #f protocol)))
-		 (uid (datum->syntax 
-		       #'record-name (if (unspecified? nongenerative) 
-					 #f nongenerative)))
-		 (sealed? (if (unspecified? sealed) #f sealed))
-		 (opaque? (if (unspecified? opaque) #f opaque))
-
-		 (record-name-sym (datum->syntax 
-				   stx (list 'quote 
-					     (syntax->datum #'record-name)))))
-		  
-		#`(begin 
-		    (define record-name 
-		      (make-record-type-descriptor 
-		       #,record-name-sym
-		       #,parent-rtd #,uid #,sealed? #,opaque? 
-		       #,field-names))
-		    (define constructor-name 
-		      (record-constructor
-		       (make-record-constructor-descriptor 
-			record-name #,parent-cd #,protocol)))
+        ((_ (record-name constructor-name predicate-name) record-clause ...)
+         (let loop ((_fields *unspecified*)
+                    (_parent *unspecified*)
+                    (_protocol *unspecified*)
+                    (_sealed *unspecified*)
+                    (_opaque *unspecified*)
+                    (_nongenerative *unspecified*)
+                    (_constructor *unspecified*)
+                    (_parent-rtd *unspecified*)
+                    (record-clauses #'(record-clause ...)))
+           (syntax-case record-clauses
+               (fields parent protocol sealed opaque nongenerative constructor parent-rtd)
+             [()
+              (let* ((fields (if (unspecified? _fields) '() _fields))
+                     (field-names (list->vector (map car fields)))
+                     (field-accessors
+                      (fold-left (lambda (x c lst)
+                                   (cons #`(define #,(cadr x)
+                                             (record-accessor record-name #,c))
+                                         lst))
+                                 '() fields (sequence (length fields))))
+                     (field-mutators
+                      (fold-left (lambda (x c lst)
+                                   (if (caddr x)
+                                       (cons #`(define #,(caddr x)
+                                                 (record-mutator record-name #,c))
+                                             lst)
+                                       lst))
+                                 '() fields (sequence (length fields))))
+                     (parent-cd (cond ((not (unspecified? _parent))
+                                       #`(record-constructor-descriptor #,_parent))
+                                      ((not (unspecified? _parent-rtd))
+                                       (cadr _parent-rtd))
+                                      (else #f)))
+                     (parent-rtd (cond ((not (unspecified? _parent))
+                                        #`(record-type-descriptor #,_parent))
+                                       ((not (unspecified? _parent-rtd))
+                                        (car _parent-rtd))
+                                       (else #f)))
+                     (protocol (if (unspecified? _protocol) #f _protocol))
+                     (uid (if (unspecified? _nongenerative) #f _nongenerative))
+                     (sealed? (if (unspecified? _sealed) #f _sealed))
+                     (opaque? (if (unspecified? _opaque) #f _opaque)))
+                #`(begin
+                    (define record-name
+                      (make-record-type-descriptor
+                       (quote record-name)
+                       #,parent-rtd #,uid #,sealed? #,opaque?
+                       #,field-names))
+                    (define constructor-name
+                      (record-constructor
+                       (make-record-constructor-descriptor
+                        record-name #,parent-cd #,protocol)))
                     (define dummy
                       (let ()
                         (register-record-type 
-                         #,record-name-sym 
+                         (quote record-name)
                          record-name (make-record-constructor-descriptor 
                                       record-name #,parent-cd #,protocol))
                         'dummy))
-		    (define predicate-name (record-predicate record-name))
-		    #,@field-accessors
-		    #,@field-mutators))
-	       (let ((cr (car record-clauses)))
-		 (case (car cr)
-		   ((fields) 
-		    (if (unspecified? fields)
-			(loop (process-fields (syntax->datum #'record-name) 
-					      (cdr cr))
-			      parent protocol sealed opaque nongenerative 
-			      constructor parent-rtd (cdr record-clauses))
-			(raise (make-assertion-violation))))
-		   ((parent)
-		    (if (not (unspecified? parent-rtd))
-			(raise (make-assertion-violation)))
-		    (if (unspecified? parent)
-			(loop fields (cadr cr) protocol sealed opaque
-			      nongenerative constructor parent-rtd
-			      (cdr record-clauses))
-			(raise (make-assertion-violation))))
-		   ((protocol) 
-		    (if (unspecified? protocol)
-			(loop fields parent (cadr cr) sealed opaque
-			      nongenerative constructor parent-rtd
-			      (cdr record-clauses))
-			(raise (make-assertion-violation))))
-		   ((sealed) 
-		    (if (unspecified? sealed)
-			(loop fields parent protocol (cadr cr) opaque
-			      nongenerative constructor parent-rtd
-			      (cdr record-clauses))
-			(raise (make-assertion-violation))))
-		   ((opaque) (if (unspecified? opaque)
-				 (loop fields parent protocol sealed (cadr cr)
-				       nongenerative constructor parent-rtd
-				       (cdr record-clauses))
-				 (raise (make-assertion-violation))))
-		   ((nongenerative) 
-		    (if (unspecified? nongenerative)
-			(let ((uid (list 'quote
-					 (or (and (> (length cr) 1) (cadr cr))
-					     (gensym)))))
-			  (loop fields parent protocol sealed
-				opaque uid constructor
-				parent-rtd (cdr record-clauses)))
-			(raise (make-assertion-violation))))
-		   ((parent-rtd) 
-		    (if (not (unspecified? parent))
-			(raise (make-assertion-violation)))
-		    (if (unspecified? parent-rtd)
-			(loop fields parent protocol sealed opaque
-			      nongenerative constructor (cdr cr)
-			      (cdr record-clauses))
-			(raise (make-assertion-violation))))
-		   (else (raise (make-assertion-violation)))))))))))
+                    (define predicate-name (record-predicate record-name))
+                    #,@field-accessors
+                    #,@field-mutators))]
+             [((fields record-fields ...) . rest)
+              (if (unspecified? _fields)
+                  (loop (process-fields #'record-name #'(record-fields ...))
+                        _parent _protocol _sealed _opaque _nongenerative
+                        _constructor _parent-rtd #'rest)
+                  (raise (make-assertion-violation)))]
+             [((parent parent-name) . rest)
+              (if (not (unspecified? _parent-rtd))
+                  (raise (make-assertion-violation))
+                  (if (unspecified? _parent)
+                      (loop _fields #'parent-name _protocol _sealed _opaque
+                            _nongenerative _constructor _parent-rtd #'rest)
+                      (raise (make-assertion-violation))))]
+             [((protocol expression) . rest)
+              (if (unspecified? _protocol)
+                  (loop _fields _parent #'expression _sealed _opaque
+                        _nongenerative _constructor _parent-rtd #'rest)
+                  (raise (make-assertion-violation)))]
+             [((sealed sealed?) . rest)
+              (if (unspecified? _sealed)
+                  (loop _fields _parent _protocol #'sealed? _opaque
+                        _nongenerative _constructor _parent-rtd #'rest)
+                  (raise (make-assertion-violation)))]
+             [((opaque opaque?) . rest)
+              (if (unspecified? _opaque)
+                  (loop _fields _parent _protocol _sealed #'opaque?
+                        _nongenerative _constructor _parent-rtd #'rest)
+                  (raise (make-assertion-violation)))]
+             [((nongenerative) . rest)
+              (if (unspecified? _nongenerative)
+                  (loop _fields _parent _protocol _sealed
+                        _opaque #`(quote #,(datum->syntax #'record-name (gensym)))
+                        _constructor _parent-rtd #'rest)
+                  (raise (make-assertion-violation)))]
+             [((nongenerative uid) . rest)
+              (if (unspecified? _nongenerative)
+                  (loop _fields _parent _protocol _sealed
+                        _opaque #''uid _constructor
+                        _parent-rtd #'rest)
+                  (raise (make-assertion-violation)))]
+             [((parent-rtd rtd cd) . rest)
+              (if (not (unspecified? _parent))
+                  (raise (make-assertion-violation))
+                  (if (unspecified? _parent-rtd)
+                      (loop _fields _parent _protocol _sealed _opaque
+                            _nongenerative _constructor #'(rtd cd)
+                            #'rest)
+                      (raise (make-assertion-violation))))]))))))
 
   (define-syntax record-type-descriptor
     (lambda (stx)
diff --git a/test-suite/tests/r6rs-records-syntactic.test b/test-suite/tests/r6rs-records-syntactic.test
index 152e31c..d320997 100644
--- a/test-suite/tests/r6rs-records-syntactic.test
+++ b/test-suite/tests/r6rs-records-syntactic.test
@@ -22,6 +22,9 @@
   :use-module ((rnrs records syntactic) :version (6))
   :use-module ((rnrs records procedural) :version (6))
   :use-module ((rnrs records inspection) :version (6))
+  :use-module ((rnrs conditions) :version (6))
+  :use-module ((rnrs exceptions) :version (6))
+  :use-module ((system base compile) #:select (compile))
   :use-module (test-suite lib))
 
 (define-record-type simple-rtd)
@@ -115,3 +118,34 @@
 
 (pass-if "record-constructor-descriptor returns rcd"
   (procedure? (record-constructor (record-constructor-descriptor simple-rtd))))
+
+(with-test-prefix "record hygiene"
+  (pass-if-exception "using shadowed record keywords fails" exception:syntax-pattern-unmatched
+     (compile '(let ((fields #f))
+                 (define-record-type foo (fields bar))
+                 #t)
+              #:env (current-module)))
+  (pass-if "using shadowed record keywords fails 2"
+    (guard (condition ((syntax-violation? condition) #t))
+      (compile '(let ((immutable #f))
+                  (define-record-type foo (fields (immutable bar)))
+                  #t)
+               #:env (current-module))
+      #f))
+  (pass-if "hygiene preserved when using macros"
+    (compile '(begin
+                (define pass #t)
+                (define-syntax define-record
+                  (syntax-rules ()
+                    ((define-record name field)
+                     (define-record-type name
+                       (protocol
+                        (lambda (x)
+                          (lambda ()
+                            ;; pass refers to pass in scope of macro not use
+                            (x pass))))
+                       (fields field)))))
+                (let ((pass #f))
+                  (define-record foo bar)
+                  (foo-bar (make-foo))))
+             #:env (current-module))))
-- 
1.7.3.4


^ permalink raw reply related	[flat|nested] 4+ messages in thread

end of thread, other threads:[~2011-06-19 19:44 UTC | newest]

Thread overview: 4+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2011-06-11 13:36 r6rs define-record-type is unhygienic Ian Price
2011-06-17  8:34 ` Andy Wingo
2011-06-17 22:36   ` Ian Price
2011-06-19 19:44     ` Andy Wingo

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).