suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix equal? on transparent R6RS records

Browse Source 
svn: r10949
This commit is contained in:
Matthew Flatt 2008-07-28 20:30:25 +00:00
parent 65ce019fbc
commit 27375c0d5a
6 changed files with 49 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/mrlib/scribblings/gif.scrbl
View File

@ -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
will be added to the last frame. @scheme[last-frame-delay] is in 1/100s of a
second units.
If @scheme[last-frame-delay] is not false, a delay of
@scheme[last-frame-delay] (in 1/100s of a second) will be added to the
last frame.}

11
collects/r6rs/private/vector-types.ss
View File

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

1
collects/rnrs/io/simple-6.ss
View File

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

2
collects/scribblings/gui/selectable-menu-item-intf.scrbl
View File

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

6
collects/tests/r6rs/base.sls
View File

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

27
collects/tests/r6rs/records/syntactic.sls
View File

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