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

cs: small repairs for chaperones

Browse Source 
The "struct.rktl" and "chaperone.rktl" tests now pass.
This commit is contained in:
Matthew Flatt 2018-10-14 18:14:50 -04:00
parent 7bb3750ebc
commit f9a69105bc
7 changed files with 142 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
pkgs/racket-test-core/tests/racket/chaperone.rktl
View File

@ -9,6 +9,8 @@
unsafe-impersonate-procedure unsafe-impersonate-procedure
unsafe-chaperone-procedure)) unsafe-chaperone-procedure))
(define secondary-hash-unused? (eq? 'cs (system-type 'gc)))
;; ---------------------------------------- ;; ----------------------------------------
(define (chaperone-of?/impersonator a b) (define (chaperone-of?/impersonator a b)
@ -116,8 +118,9 @@
(test "bad get" exn-message exn))) (test "bad get" exn-message exn)))
(err/rt-test (equal-hash-code b2) (lambda (exn) (err/rt-test (equal-hash-code b2) (lambda (exn)
(test "bad get" exn-message exn))) (test "bad get" exn-message exn)))
(unless secondary-hash-unused?
(err/rt-test (equal-secondary-hash-code b2) (lambda (exn) (err/rt-test (equal-secondary-hash-code b2) (lambda (exn)
(test "bad get" exn-message exn))) (test "bad get" exn-message exn))))
(err/rt-test (equal? b2 (box 'bad)) (lambda (exn) (err/rt-test (equal? b2 (box 'bad)) (lambda (exn)
(test "bad get" exn-message exn))) (test "bad get" exn-message exn)))
(test (void) set-box! b 'ok) (test (void) set-box! b 'ok)
@ -1563,9 +1566,10 @@
[c1 (chaperone-struct (c 1) c-n (lambda (b v) (set! got? #t) v))]) [c1 (chaperone-struct (c 1) c-n (lambda (b v) (set! got? #t) v))])
(void (equal-hash-code c1)) (void (equal-hash-code c1))
(test #t values got?) (test #t values got?)
(unless secondary-hash-unused?
(set! got? #f) (set! got? #f)
(void (equal-secondary-hash-code c1)) (void (equal-secondary-hash-code c1))
(test #t values got?) (test #t values got?))
(define c3 (c 1)) (define c3 (c 1))
(set! got? #f) (set! got? #f)
(void (equal? c1 c3)) (void (equal? c1 c3))
@ -1589,10 +1593,11 @@
set-d-n! (lambda (b v) v))) set-d-n! (lambda (b v) v)))
(void (equal-hash-code d1)) (void (equal-hash-code d1))
(test '(#t #t) list got? mine?) (test '(#t #t) list got? mine?)
(unless secondary-hash-unused?
(set! got? #f) (set! got? #f)
(set! mine? #f) (set! mine? #f)
(void (equal-secondary-hash-code d1)) (void (equal-secondary-hash-code d1))
(test '(#t #t) list got? mine?) (test '(#t #t) list got? mine?))
(define d3 (d 1)) (define d3 (d 1))
(set! got? #f) (set! got? #f)
(set! mine? #f) (set! mine? #f)
@ -1611,9 +1616,10 @@
(define d1 (chaperone-struct (d 1) d-n (lambda (b v) (set! got? #t) v))) (define d1 (chaperone-struct (d 1) d-n (lambda (b v) (set! got? #t) v)))
(void (equal-hash-code d1)) (void (equal-hash-code d1))
(test '(#t) list got?) (test '(#t) list got?)
(unless secondary-hash-unused?
(set! got? #f) (set! got? #f)
(void (equal-secondary-hash-code d1)) (void (equal-secondary-hash-code d1))
(test '(#t) list got?) (test '(#t) list got?))
(define d3 (d 1)) (define d3 (d 1))
(set! got? #f) (set! got? #f)
(test #t values (equal? d1 d3)) (test #t values (equal? d1 d3))
@ -1961,9 +1967,10 @@
(set! get-v #f) (set! get-v #f)
(void (equal-hash-code h2)) (void (equal-hash-code h2))
(test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k) (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k)
(unless secondary-hash-unused?
(set! get-k #f) (set! get-k #f)
(set! get-v #f) (set! get-v #f)
(void (equal-secondary-hash-code h2)) (void (equal-secondary-hash-code h2)))
(test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k) (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k)
(set! get-k #f) (set! get-k #f)
(set! get-v #f) (set! get-v #f)
@ -2031,9 +2038,10 @@
(set! get-v #f) (set! get-v #f)
(void (equal-hash-code h2)) (void (equal-hash-code h2))
(test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k) (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k)
(unless secondary-hash-unused?
(set! get-k #f) (set! get-k #f)
(set! get-v #f) (set! get-v #f)
(void (equal-secondary-hash-code h2)) (void (equal-secondary-hash-code h2)))
(test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k) (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k)
(set! get-k #f) (set! get-k #f)
(set! get-v #f) (set! get-v #f)

2
racket/src/cs/demo/chaperone.ss
View File

@ -348,7 +348,7 @@
(check (ops!) '(set equal-key)) (check (ops!) '(set equal-key))
(check (hash-ref (hash-remove ht1c 1) 1 'none) 'none) (check (hash-ref (hash-remove ht1c 1) 1 'none) 'none)
(check (ops!) '(remove equal-key get equal-key)) (check (ops!) '(remove equal-key get equal-key equal-key))
(check (begin (check (begin
(hash-remove! ht2c 1) (hash-remove! ht2c 1)
(hash-ref ht2c 1 'none)) (hash-ref ht2c 1 'none))

6
racket/src/cs/rumble/equal.ss
View File

@ -89,7 +89,7 @@
(equal? (unbox orig-a) (unbox orig-b) ctx)))))] (equal? (unbox orig-a) (unbox orig-b) ctx)))))]
[(record? a) [(record? a)
(and (record? b) (and (record? b)
;; Check for for `prop:impersonator-of` ;; Check for `prop:impersonator-of`
(let ([a2 (and (not (eq? mode 'chaperone-of?)) (let ([a2 (and (not (eq? mode 'chaperone-of?))
(extract-impersonator-of mode a))] (extract-impersonator-of mode a))]
[b2 (and (eq? mode 'equal?) [b2 (and (eq? mode 'equal?)
@ -100,7 +100,7 @@
;; other forms of checking ;; other forms of checking
(or (check-union-find ctx a b) (or (check-union-find ctx a b)
(let ([ctx (deeper-context ctx)]) (let ([ctx (deeper-context ctx)])
(equal? (or a a2) (or b b2) ctx)))] (equal? (or a2 a) (or b2 b) ctx)))]
[else [else
;; No `prop:impersonator-of`, so check for ;; No `prop:impersonator-of`, so check for
;; `prop:equal+hash` or transparency ;; `prop:equal+hash` or transparency
@ -135,7 +135,7 @@
(define/who (equal?/recur a b eql?) (define/who (equal?/recur a b eql?)
(check who (procedure-arity-includes/c 2) eql?) (check who (procedure-arity-includes/c 2) eql?)
(do-equal? a b 'equal?/recur eql?)) (do-equal? a b 'equal? eql?))
;; ---------------------------------------- ;; ----------------------------------------

61
racket/src/cs/rumble/hash.ss
View File

@ -129,7 +129,12 @@
(let ([ht (impersonator-val ht)]) (let ([ht (impersonator-val ht)])
(or (mutable-hash? ht) (or (mutable-hash? ht)
(weak-equal-hash? ht)))) (weak-equal-hash? ht))))
(impersonate-hash-clear! ht)] (unless (impersonate-hash-clear ht #t)
;; fall back to iterated remove
(let loop ([i (hash-iterate-first ht)])
(when i
(hash-remove! ht (hash-iterate-key ht i))
(loop (hash-iterate-next ht i)))))]
[else (raise-argument-error 'hash-clear! "(and/c hash? (not/c immutable?))" ht)])) [else (raise-argument-error 'hash-clear! "(and/c hash? (not/c immutable?))" ht)]))
(define (hash-copy ht) (define (hash-copy ht)
@ -185,11 +190,13 @@
[else empty-hash])] [else empty-hash])]
[(and (impersonator? ht) [(and (impersonator? ht)
(intmap? (impersonator-val ht))) (intmap? (impersonator-val ht)))
(or (impersonate-hash-clear ht #f)
;; fall back to iterated remove
(let loop ([ht ht]) (let loop ([ht ht])
(let ([i (hash-iterate-first ht)]) (let ([i (hash-iterate-first ht)])
(if i (if i
(loop (hash-remove ht (hash-iterate-key ht i))) (loop (hash-remove ht (hash-iterate-key ht i)))
ht)))] ht))))]
[else (raise-argument-error 'hash-clear! "(and/c hash? immutable?)" ht)])) [else (raise-argument-error 'hash-clear! "(and/c hash? immutable?)" ht)]))
(define (hash-eq? ht) (define (hash-eq? ht)
@ -963,16 +970,20 @@
(check who (procedure-arity-includes/c 2) key) (check who (procedure-arity-includes/c 2) key)
(let* ([clear-given? (and (pair? args) (let* ([clear-given? (and (pair? args)
(or (not (car args)) (or (not (car args))
(and (procedure? (car args)) (procedure? (car args))))]
(procedure-arity-includes? (car args) 1))))] [clear (if clear-given?
[clear (if clear-given? (car args) void)] (let ([clear (car args)])
(check who (procedure-arity-includes/c 1) :or-false clear)
clear)
void)]
[args (if clear-given? (cdr args) args)] [args (if clear-given? (cdr args) args)]
[equal-key-given? (and (pair? args) [equal-key-given? (and (pair? args)
(or (not (car args)) (or (not (car args))
(and (procedure? (car args)) (procedure? (car args))))]
(procedure-arity-includes? (car args) 2))))]
[equal-key (if equal-key-given? [equal-key (if equal-key-given?
(car args) (let ([equal-key (car args)])
(check who (procedure-arity-includes/c 2) :or-false equal-key)
equal-key)
(lambda (ht k) k))] (lambda (ht k) k))]
[args (if equal-key-given? (cdr args) args)]) [args (if equal-key-given? (cdr args) args)])
(make-hash-chaperone (strip-impersonator ht) (make-hash-chaperone (strip-impersonator ht)
@ -1103,7 +1114,7 @@
(raise-chaperone-error who "key" new-k k)) (raise-chaperone-error who "key" new-k k))
new-k))) new-k)))
(define (impersonate-hash-clear! ht) (define (impersonate-hash-clear ht mutable?)
(let loop ([ht ht]) (let loop ([ht ht])
(cond (cond
[(or (hash-impersonator? ht) [(or (hash-impersonator? ht)
@ -1111,13 +1122,33 @@
(let ([procs (if (hash-impersonator? ht) (let ([procs (if (hash-impersonator? ht)
(hash-impersonator-procs ht) (hash-impersonator-procs ht)
(hash-chaperone-procs ht))] (hash-chaperone-procs ht))]
[ht (impersonator-next ht)]) [next-ht (impersonator-next ht)])
((hash-procs-clear procs) ht) (let ([clear (hash-procs-clear procs)])
(loop ht))] (cond
[(impersonator? ht) [clear
(loop (impersonator-next ht))] (clear next-ht)
(if mutable?
(loop next-ht)
(let ([r (loop next-ht)])
(and r
((if (chaperone? ht) make-hash-chaperone make-hash-impersonator)
(strip-impersonator r)
r
(impersonator-props ht)
procs))))]
[else [else
(hash-clear! ht)]))) ;; Fall back to iterate of remove
#f])))]
[(impersonator? ht)
(if mutable?
(loop (impersonator-next ht))
(let ([r (loop (impersonator-next ht))])
(and r
(rewrap-props-impersonator ht r))))]
[else
(if mutable?
(hash-clear! ht)
(hash-clear ht))])))
(define (impersonate-hash-copy ht) (define (impersonate-hash-copy ht)
(let* ([val-ht (impersonator-val ht)] (let* ([val-ht (impersonator-val ht)]

68
racket/src/cs/rumble/impersonator.ss
View File

@ -309,15 +309,12 @@
(define-record procedure~-struct-chaperone procedure-struct-chaperone ()) (define-record procedure~-struct-chaperone procedure-struct-chaperone ())
(define (impersonate-struct v . args) (define (impersonate-struct v . args)
(do-impersonate-struct 'impersonate-struct #f v args (do-impersonate-struct 'impersonate-struct #f v args))
make-struct-impersonator make-procedure~-struct-impersonator make-procedure-struct-impersonator))
(define (chaperone-struct v . args) (define (chaperone-struct v . args)
(do-impersonate-struct 'chaperone-struct #t v args (do-impersonate-struct 'chaperone-struct #t v args))
make-struct-chaperone make-procedure-struct-chaperone make-procedure~-struct-chaperone))
(define (do-impersonate-struct who as-chaperone? v args (define (do-impersonate-struct who as-chaperone? v args)
make-struct-impersonator make-procedure-struct-impersonator make-procedure~-struct-impersonator)
(cond (cond
[(null? args) v] [(null? args) v]
[else [else
@ -339,25 +336,26 @@
[iprops orig-iprops]) [iprops orig-iprops])
(let ([get-proc (let ([get-proc
(lambda (what args arity proc->key key-applies?) (lambda (what args arity proc->key key-applies?)
(let* ([key-proc (strip-impersonator (car args))] (let* ([orig-proc (car args)]
[key-proc (strip-impersonator orig-proc)]
[key (proc->key key-proc)]) [key (proc->key key-proc)])
(when (hash-ref saw-props key #f) (when (hash-ref saw-props key #f)
(raise-arguments-error who (raise-arguments-error who
"given operation accesses the same value as a previous operation argument" "given operation accesses the same value as a previous operation argument"
"operation kind" what "operation kind" what
"operation procedure" (car args))) "operation procedure" orig-proc))
(when key-applies? (when key-applies?
(unless (key-applies? key val) (unless (key-applies? key val)
(raise-arguments-error who (raise-arguments-error who
"operation does not apply to given value" "operation does not apply to given value"
"operation kind" what "operation kind" what
"operation procedure" (car args) "operation procedure" orig-proc
"value" v))) "value" v)))
(when (null? (cdr args)) (when (null? (cdr args))
(raise-arguments-error who (raise-arguments-error who
"missing redirection procedure after operation" "missing redirection procedure after operation"
"operation kind" what "operation kind" what
"operation procedure" (car args))) "operation procedure" orig-proc))
(let ([proc (cadr args)]) (let ([proc (cadr args)])
(when proc (when proc
(unless (procedure-arity-includes? proc arity) (unless (procedure-arity-includes? proc arity)
@ -367,13 +365,19 @@
"expected" (string-append "expected" (string-append
"(or/c #f (procedure-arity-includes/c " (number->string arity) "))") "(or/c #f (procedure-arity-includes/c " (number->string arity) "))")
"operation kind" what "operation kind" what
"operation procedure" (car args)))) "operation procedure" orig-proc)))
(when (and as-chaperone?
(and (impersonator? orig-proc)
(not (chaperone? orig-proc))))
(raise-arguments-error who
"impersonated operation cannot be used to create a chaperone"
"operation" orig-proc))
(loop #f (loop #f
(cddr args) (cddr args)
(if proc (if proc
(hash-set props key (hash-set props key
(if (impersonator? (car args)) (if (impersonator? orig-proc)
(cons (car args) ; save original accessor, in case it's impersonated (cons orig-proc ; save original accessor, in case it's impersonated
proc) ; the interposition proc proc) ; the interposition proc
proc)) proc))
props) props)
@ -400,14 +404,40 @@
(if as-chaperone? "chaperone" "impersonate") (if as-chaperone? "chaperone" "impersonate")
" instance of an authentic structure type") " instance of an authentic structure type")
"given value" v)) "given value" v))
(if (and (zero? (hash-count props)) (cond
(eq? iprops orig-iprops)) [(zero? (hash-count props))
v ;; No structure operations chaperoned, so either unchanged or
;; a properties-only impersonator
(cond
[(eq? iprops orig-iprops)
v]
[else
;; Same six cases as below, but for a propery-only impersonator
(if (procedure? val) (if (procedure? val)
(if (procedure-incomplete-arity? val) (if (procedure-incomplete-arity? val)
(make-procedure~-struct-impersonator val v iprops props (procedure-arity-mask v)) (if as-chaperone?
(make-procedure-struct-impersonator val v iprops props (procedure-arity-mask v))) (make-props-procedure~-chaperone val v iprops (procedure-arity-mask v))
(make-struct-impersonator val v iprops props)))] (make-props-procedure~-impersonator val v iprops (procedure-arity-mask v)))
(if as-chaperone?
(make-props-procedure-chaperone val v iprops (procedure-arity-mask v))
(make-props-procedure-impersonator val v iprops (procedure-arity-mask v))))
(if as-chaperone?
(make-props-chaperone val v iprops)
(make-props-impersonator val v iprops)))])]
[(procedure? val)
;; Wrap as a procedure-struct impersonator
(if (procedure-incomplete-arity? val)
(if as-chaperone?
(make-procedure~-struct-chaperone val v iprops props (procedure-arity-mask v))
(make-procedure~-struct-impersonator val v iprops props (procedure-arity-mask v)))
(if as-chaperone?
(make-procedure-struct-chaperone val v iprops props (procedure-arity-mask v))
(make-procedure-struct-impersonator val v iprops props (procedure-arity-mask v))))]
[else
;; Wrap as a plain old struct impersonator
(if as-chaperone?
(make-struct-chaperone val v iprops props)
(make-struct-impersonator val v iprops props))])]
[(impersonator-property? (car args)) [(impersonator-property? (car args))
(loop #f (loop #f
'() '()

2
racket/src/cs/rumble/intmap.ss
View File

@ -240,7 +240,7 @@
(define-syntax-rule (key=? et k1 k2) (define-syntax-rule (key=? et k1 k2)
(cond [(eq? et 'eq) (eq? k1 k2)] (cond [(eq? et 'eq) (eq? k1 k2)]
[(eq? et 'eqv) (eqv? k1 k2)] [(eq? et 'eqv) (eqv? k1 k2)]
[else (equal? k1 k2)])) [else (key-equal? k1 k2)]))
(define-syntax-rule (hash-code et k) (define-syntax-rule (hash-code et k)
(cond [(eq? et 'eq) (eq-hash-code k)] (cond [(eq? et 'eq) (eq-hash-code k)]

27
racket/src/cs/rumble/procedure.ss
View File

@ -192,10 +192,7 @@
[(fixnum? v) [(fixnum? v)
(proc-arity-mask (unsafe-struct-ref f v) shift)] (proc-arity-mask (unsafe-struct-ref f v) shift)]
[(eq? v 'unsafe) [(eq? v 'unsafe)
(proc-arity-mask (if (chaperone? f) (proc-arity-mask (impersonator-next f) shift)]
(unsafe-procedure-chaperone-replace-proc f)
(unsafe-procedure-impersonator-replace-proc f))
shift)]
[else [else
(proc-arity-mask v (add1 shift))]))]))]))] (proc-arity-mask v (add1 shift))]))]))]))]
[(eq? f orig-f) [(eq? f orig-f)
@ -446,12 +443,12 @@
(lambda (n) (bitwise-arithmetic-shift-right n 1)) " (adding an extra argument)")) (lambda (n) (bitwise-arithmetic-shift-right n 1)) " (adding an extra argument)"))
(define (do-impersonate-procedure who make-procedure-impersonator proc wrapper (define (do-impersonate-procedure who make-procedure-impersonator proc wrapper
make-props-procedure-impersonator props make-props-procedure-impersonator props-l
arity-shift arity-shift-str) arity-shift arity-shift-str)
(check who procedure? proc) (check who procedure? proc)
(let ([m (procedure-arity-mask proc)]) (let ([m (procedure-arity-mask proc)])
(when wrapper (when wrapper
(check who procedure? wrapper) (check who procedure? :or-false wrapper)
(unless (= m (bitwise-and m (arity-shift (procedure-arity-mask wrapper)))) (unless (= m (bitwise-and m (arity-shift (procedure-arity-mask wrapper))))
(raise-arguments-error who (raise-arguments-error who
(string-append (string-append
@ -463,13 +460,15 @@
(impersonator-val proc) (impersonator-val proc)
proc)] proc)]
[props (add-impersonator-properties who [props (add-impersonator-properties who
props props-l
(if (impersonator? proc) (if (impersonator? proc)
(impersonator-props proc) (intmap-remove (impersonator-props proc) impersonator-prop:application-mark)
empty-hasheq))]) empty-hasheq))])
(if wrapper (cond
(make-procedure-impersonator val proc props wrapper m) [wrapper (make-procedure-impersonator val proc props wrapper m)]
(make-props-procedure-impersonator val proc props m))))) [(null? props-l) proc]
[else
(make-props-procedure-impersonator val proc props m)]))))
(define (procedure-impersonator*? v) (define (procedure-impersonator*? v)
(or (procedure*-impersonator? v) (or (procedure*-impersonator? v)
@ -689,7 +688,7 @@
(do-unsafe-impersonate-procedure who make-unsafe-procedure-chaperone (do-unsafe-impersonate-procedure who make-unsafe-procedure-chaperone
proc replace-proc props)) proc replace-proc props))
(define (do-unsafe-impersonate-procedure who make-unsafe-procedure-impersonator proc replace-proc props) (define (do-unsafe-impersonate-procedure who make-unsafe-procedure-impersonator proc replace-proc props-l)
(let ([m (procedure-arity-mask proc)]) (let ([m (procedure-arity-mask proc)])
(unless (= m (bitwise-and m (procedure-arity-mask replace-proc))) (unless (= m (bitwise-and m (procedure-arity-mask replace-proc)))
(raise-arguments-error who (raise-arguments-error who
@ -700,9 +699,9 @@
(strip-impersonator proc) (strip-impersonator proc)
proc proc
(add-impersonator-properties who (add-impersonator-properties who
props props-l
(if (impersonator? proc) (if (impersonator? proc)
(impersonator-props proc) (intmap-remove (impersonator-props proc) impersonator-prop:application-mark)
empty-hasheq)) empty-hasheq))
replace-proc))) replace-proc)))