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

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

@ -348,7 +348,7 @@
(check (ops!) '(set equal-key))
(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
(hash-remove! ht2c 1)
(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)))))]
[(record? a)
(and (record? b)
;; Check for for `prop:impersonator-of`
;; Check for `prop:impersonator-of`
(let ([a2 (and (not (eq? mode 'chaperone-of?))
(extract-impersonator-of mode a))]
[b2 (and (eq? mode 'equal?)
@ -100,7 +100,7 @@
;; other forms of checking
(or (check-union-find ctx a b)
(let ([ctx (deeper-context ctx)])
(equal? (or a a2) (or b b2) ctx)))]
(equal? (or a2 a) (or b2 b) ctx)))]
[else
;; No `prop:impersonator-of`, so check for
;; `prop:equal+hash` or transparency
@ -135,7 +135,7 @@
(define/who (equal?/recur a b 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)])
(or (mutable-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)]))
(define (hash-copy ht)
@ -185,11 +190,13 @@
[else empty-hash])]
[(and (impersonator? ht)
(intmap? (impersonator-val ht)))
(or (impersonate-hash-clear ht #f)
;; fall back to iterated remove
(let loop ([ht ht])
(let ([i (hash-iterate-first ht)])
(if i
(loop (hash-remove ht (hash-iterate-key ht i)))
ht)))]
ht))))]
[else (raise-argument-error 'hash-clear! "(and/c hash? immutable?)" ht)]))
(define (hash-eq? ht)
@ -963,16 +970,20 @@
(check who (procedure-arity-includes/c 2) key)
(let* ([clear-given? (and (pair? args)
(or (not (car args))
(and (procedure? (car args))
(procedure-arity-includes? (car args) 1))))]
[clear (if clear-given? (car args) void)]
(procedure? (car args))))]
[clear (if clear-given?
(let ([clear (car args)])
(check who (procedure-arity-includes/c 1) :or-false clear)
clear)
void)]
[args (if clear-given? (cdr args) args)]
[equal-key-given? (and (pair? args)
(or (not (car args))
(and (procedure? (car args))
(procedure-arity-includes? (car args) 2))))]
(procedure? (car args))))]
[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))]
[args (if equal-key-given? (cdr args) args)])
(make-hash-chaperone (strip-impersonator ht)
@ -1103,7 +1114,7 @@
(raise-chaperone-error who "key" new-k k))
new-k)))
(define (impersonate-hash-clear! ht)
(define (impersonate-hash-clear ht mutable?)
(let loop ([ht ht])
(cond
[(or (hash-impersonator? ht)
@ -1111,13 +1122,33 @@
(let ([procs (if (hash-impersonator? ht)
(hash-impersonator-procs ht)
(hash-chaperone-procs ht))]
[ht (impersonator-next ht)])
((hash-procs-clear procs) ht)
(loop ht))]
[(impersonator? ht)
(loop (impersonator-next ht))]
[next-ht (impersonator-next ht)])
(let ([clear (hash-procs-clear procs)])
(cond
[clear
(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
(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)
(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 (impersonate-struct v . args)
(do-impersonate-struct 'impersonate-struct #f v args
make-struct-impersonator make-procedure~-struct-impersonator make-procedure-struct-impersonator))
(do-impersonate-struct 'impersonate-struct #f v args))
(define (chaperone-struct v . args)
(do-impersonate-struct 'chaperone-struct #t v args
make-struct-chaperone make-procedure-struct-chaperone make-procedure~-struct-chaperone))
(do-impersonate-struct 'chaperone-struct #t v args))
(define (do-impersonate-struct who as-chaperone? v args
make-struct-impersonator make-procedure-struct-impersonator make-procedure~-struct-impersonator)
(define (do-impersonate-struct who as-chaperone? v args)
(cond
[(null? args) v]
[else
@ -339,25 +336,26 @@
[iprops orig-iprops])
(let ([get-proc
(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)])
(when (hash-ref saw-props key #f)
(raise-arguments-error who
"given operation accesses the same value as a previous operation argument"
"operation kind" what
"operation procedure" (car args)))
"operation procedure" orig-proc))
(when key-applies?
(unless (key-applies? key val)
(raise-arguments-error who
"operation does not apply to given value"
"operation kind" what
"operation procedure" (car args)
"operation procedure" orig-proc
"value" v)))
(when (null? (cdr args))
(raise-arguments-error who
"missing redirection procedure after operation"
"operation kind" what
"operation procedure" (car args)))
"operation procedure" orig-proc))
(let ([proc (cadr args)])
(when proc
(unless (procedure-arity-includes? proc arity)
@ -367,13 +365,19 @@
"expected" (string-append
"(or/c #f (procedure-arity-includes/c " (number->string arity) "))")
"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
(cddr args)
(if proc
(hash-set props key
(if (impersonator? (car args))
(cons (car args) ; save original accessor, in case it's impersonated
(if (impersonator? orig-proc)
(cons orig-proc ; save original accessor, in case it's impersonated
proc) ; the interposition proc
proc))
props)
@ -400,14 +404,40 @@
(if as-chaperone? "chaperone" "impersonate")
" instance of an authentic structure type")
"given value" v))
(if (and (zero? (hash-count props))
(eq? iprops orig-iprops))
v
(cond
[(zero? (hash-count props))
;; 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-incomplete-arity? val)
(make-procedure~-struct-impersonator val v iprops props (procedure-arity-mask v))
(make-procedure-struct-impersonator val v iprops props (procedure-arity-mask v)))
(make-struct-impersonator val v iprops props)))]
(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-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))
(loop #f
'()

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

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

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

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