fix equal? on transparent R6RS records

svn: r10949

collects/mrlib/scribblings/gif.scrbl

@@ -48,8 +48,8 @@ written to the file one at a time; that is, for each thunk in
 @scheme[bitmap-list], its result is written and discarded before
 another thunk is called. A drawback to this approach is that a
 separate colortable is written for each frame in the animation, which
-can make the resulting file large.}
+can make the resulting file large.
 
-If @scheme[last-frame-delay] is not false, a delay of last-frame-delay
+If @scheme[last-frame-delay] is not false, a delay of
-will be added to the last frame.  @scheme[last-frame-delay] is in 1/100s of a
+@scheme[last-frame-delay] (in 1/100s of a second) will be added to the
-second units.
+last frame.}

collects/r6rs/private/vector-types.ss

@@ -52,7 +52,16 @@
                                     (and supertype
                                          (vector-type-struct-type supertype))
                                     (length field-mutability) 0 #f
-                                    (list (cons prop:typed-vector bx))
+                                    (append (list (cons prop:typed-vector bx))
+                                            (if opaque?
+                                                null
+                                                ;; `equal?' shouldn't work on transparent structs:
+                                                (list
+                                                 (cons prop:equal+hash
+                                                       (list 
+                                                        (lambda (a b equal?) (eqv? a b))
+                                                        (lambda (a hash-code) (hash-code a))
+                                                        (lambda (a hash-code) (hash-code a)))))))
                                     (and opaque? (current-inspector))
                                     #f ; not a procedure
                                     (let loop ([field-mutability field-mutability]

collects/rnrs/io/simple-6.ss

@@ -73,6 +73,7 @@
 (define (r6rs:display v [out (r6rs:current-output-port)])
   (unless (r6rs:textual-port? out)
     (raise-type-error 'display "textual port" out))
+  ;; Should we make mpairs print with parens?
   (display v out))
 
 (define (r6rs:write v [out (r6rs:current-output-port)])

collects/scribblings/gui/selectable-menu-item-intf.scrbl

@@ -51,7 +51,7 @@ Returns a list of symbols that indicates the keyboard prefix used for the menu
 @item{@scheme['meta] --- Meta (X only)}
 @item{@scheme['ctl] --- Control}
 @item{@scheme['shift] --- Shift}
-@item{@scheme['opt] --- Option (Mac OS X only)}
+@item{@scheme['option] --- Option (Mac OS X only)}
 }
 
 Under X, at most one of @scheme['alt] and @scheme['meta] can be

collects/tests/r6rs/base.sls

@@ -182,6 +182,12 @@
                 'should-not-get-here)
               &assertion)
 
+    (test (letrec ([x (if (eq? (cons 1 2) (cons 1 2))
+                          x
+                          1)]) 
+            x)
+          1)
+
     ;; 11.4.1
     ;; (These tests are especially silly, since they really
     ;;  have to work to get this far.)

collects/tests/r6rs/records/syntactic.sls

@@ -81,6 +81,11 @@
   
   (define ex3-i1 (make-ex3 1 2 17))
 
+  (define-record-type (tag make-tag tag?))
+  (define-record-type (otag make-otag otag?) (opaque #t))
+  (define-record-type (stag make-stag stag?) (sealed #t))
+  (define-record-type (ostag make-ostag ostag?) (opaque #t) (sealed #t))
+  
   ;; ----------------------------------------
 
   (define (run-records-syntactic-tests)
@@ -144,6 +149,28 @@
     (test (record-field-mutable? (record-type-descriptor point) 1) #t)
     (test (record-field-mutable? (record-type-descriptor cpoint) 0) #t)
 
+    ;; Tests from Alan Watson:
+    (test (eqv? (equal? (make-tag) (make-tag)) (eqv? (make-tag) (make-tag)))
+          #t)
+    (test (eqv? (equal? (make-otag) (make-otag)) (eqv? (make-otag) (make-otag)))
+          #t)
+    (test (eqv? (equal? (make-stag) (make-stag)) (eqv? (make-stag) (make-stag)))
+          #t)
+    (test (eqv? (equal? (make-ostag) (make-ostag)) (eqv? (make-ostag) (make-ostag)))
+          #t)
+    (test (let ([t (make-tag)])
+            (eqv? (equal? t t) (eqv? t t)))
+          #t)
+    (test (let ([t (make-otag)])
+            (eqv? (equal? t t) (eqv? t t)))
+          #t)
+    (test (let ([t (make-stag)])
+            (eqv? (equal? t t) (eqv? t t)))
+          #t)
+    (test (let ([t (make-ostag)])
+            (eqv? (equal? t t) (eqv? t t)))
+          #t)
+
     ;;
     ))