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

cs: fix some structure and imperonsator problems

Browse Source
This commit is contained in:
Matthew Flatt 2018-10-14 16:38:29 -04:00
parent 2b39e61c4e
commit 7bb3750ebc
5 changed files with 56 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-test-core/tests/racket/struct.rktl
View File

@ -1105,7 +1105,7 @@
(define thing.id! (make-struct-field-mutator thing-set! 0))
(test #t struct-mutator-procedure? thing.id!)
(err/rt-test (thing.id! 'new-val))
(err/rt-test (thing.id! (make-thing 1) 'new-val))
(let ([f #f])
;; defeat inlining to ensure that thunk is JITted:

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

@ -107,12 +107,18 @@
(let ([rec-equal? (record-equal-procedure a b)])
(and rec-equal?
(or (check-union-find ctx a b)
(if eql?
(rec-equal? orig-a orig-b eql?)
(let ([ctx (deeper-context ctx)])
(rec-equal? orig-a orig-b
(lambda (a b)
(equal? a b ctx))))))))])))]
(cond
[eql?
(rec-equal? orig-a orig-b eql?)]
[(and (eq? mode 'chaperone-of?)
(with-global-lock* (hashtable-contains? rtd-mutables (record-rtd a))))
;; Mutable records must be `eq?` for `chaperone-of?`
#f]
[else
(let ([ctx (deeper-context ctx)])
(rec-equal? orig-a orig-b
(lambda (a b)
(equal? a b ctx))))]))))])))]
[(and (eq? mode 'chaperone-of?)
;; Mutable strings and bytevectors must be `eq?` for `chaperone-of?`
(or (mutable-string? a)

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

@ -72,12 +72,12 @@
(define (slow-extract-procedure f n-args)
(pariah ; => don't inline enclosing procedure
(do-extract-procedure f f n-args #f)))
(do-extract-procedure f f n-args #f not-a-procedure)))
;; Returns a host-Scheme procedure, but first checks arity so that
;; checking and reporting use the right top-level function, and
;; the returned procedure may just report a not-a-procedure error
(define (do-extract-procedure f orig-f n-args success-k)
(define (do-extract-procedure f orig-f n-args success-k fail-k)
(cond
[(#%procedure? f)
(if (chez:procedure-arity-includes? f n-args)
@ -89,14 +89,14 @@
(let* ([rtd (record-rtd f)]
[v (struct-property-ref prop:procedure rtd none)])
(cond
[(eq? v none) (not-a-procedure orig-f)]
[(eq? v none) (fail-k orig-f)]
[(fixnum? v)
(let ([a (struct-property-ref prop:procedure-arity rtd #f)])
(cond
[(and a (not (bitwise-bit-set? (unsafe-struct*-ref f a) n-args)))
(wrong-arity-wrapper orig-f)]
[else
(do-extract-procedure (unsafe-struct-ref f v) orig-f n-args success-k)]))]
(do-extract-procedure (unsafe-struct-ref f v) orig-f n-args success-k wrong-arity-wrapper)]))]
[(eq? v 'unsafe)
(do-extract-procedure
(if (chaperone? f)
@ -104,7 +104,8 @@
(unsafe-procedure-impersonator-replace-proc f))
orig-f
n-args
success-k)]
success-k
wrong-arity-wrapper)]
[else
(let ([a (struct-property-ref prop:procedure-arity rtd #f)])
(cond
@ -124,8 +125,9 @@
[(a) (v f a)]
[(a b) (v f a b)]
[(a b c) (v f a b c)]
[args (chez:apply v f args)])])))]))]))]
[else (not-a-procedure orig-f)]))
[args (chez:apply v f args)])]))
wrong-arity-wrapper)]))]))]
[else (fail-k orig-f)]))
(define (extract-procedure-name f)
(cond

40
racket/src/cs/rumble/struct.ss
View File

@ -346,7 +346,8 @@
;; ----------------------------------------
;; Records which fields of an rtd are mutable, where an rtd that is
;; not in the table has no mutable fields:
;; not in the table has no mutable fields, and the field list can be
;; empty if a parent type is mutable:
(define rtd-mutables (make-ephemeron-eq-hashtable))
;; Accessors and mutators that need a position are wrapped in these records:
@ -517,8 +518,8 @@
(cons prop:procedure props)
props))])
(with-global-lock* (hashtable-set! rtd-props rtd props)))
(unless (equal? '#() mutables)
(with-global-lock* (hashtable-set! rtd-mutables rtd mutables)))
(with-global-lock*
(register-mutables! mutables rtd parent-rtd*))
;; Copy parent properties for this type:
(for-each (lambda (prop)
(let loop ([prop prop])
@ -598,11 +599,17 @@
(unless parent-rtd
(record-type-equal-procedure rtd default-struct-equal?)
(record-type-hash-procedure rtd default-struct-hash))
(unless (equal? mutables '#())
(hashtable-set! rtd-mutables rtd mutables))
(register-mutables! mutables rtd parent-rtd)
(inspector-set! rtd 'prefab)
rtd])))]))
;; call with lock held
(define (register-mutables! mutables rtd parent-rtd)
(unless (and (equal? '#() mutables)
(or (not parent-rtd)
(not (hashtable-contains? rtd-mutables parent-rtd))))
(hashtable-set! rtd-mutables rtd mutables)))
(define (check-accessor-or-mutator-index who rtd pos)
(let* ([total-count (#%vector-length (record-type-field-names rtd))])
(unless (< pos total-count)
@ -653,11 +660,22 @@
(let* ([abs-pos (+ pos (position-based-mutator-offset pbm))]
[p (record-field-mutator rtd abs-pos)]
[wrap-p
(escapes-ok
(lambda (v a)
(if (impersonator? v)
(impersonate-set! p rtd pos abs-pos v a)
(p v a))))])
(if (struct-type-field-mutable? rtd pos)
(lambda (v a)
(if (impersonator? v)
(impersonate-set! p rtd pos abs-pos v a)
(p v a)))
(lambda (v a)
(raise-arguments-error (string->symbol
(string-append (symbol->string (record-type-name rtd))
"-"
(if name
(symbol->string name)
(string-append "field" (number->string pos)))
"!"))
"cannot modify value of immutable field in structure"
"structure" v
"field index" pos)))])
(register-struct-field-mutator! wrap-p rtd pos)
wrap-p))]
[(pbm pos)
@ -798,7 +816,7 @@
(apply guard (append-n args init*-count (list name))))
(lambda results
(unless (= (length results) init*-count)
(raise-result-arity-error "calling guard procedure" init*-count results))
(apply raise-result-arity-error '|calling guard procedure| init*-count #f results))
(loop (cdr guards)
(if (= init*-count (length args))
results

10
racket/src/io/print/main.rkt
View File

@ -284,13 +284,13 @@
[(mpair? v)
(print-mlist p who v mode o max-length graph config)]
[(custom-write? v)
(let ([o (make-output-port/max o max-length)])
(let ([o/m (make-output-port/max o max-length)])
(set-port-handlers-to-recur!
o
o/m
(lambda (v o mode)
(p who v mode o (output-port/max-max-length o max-length) graph config)))
((custom-write-accessor v) v o mode)
(output-port/max-max-length o max-length))]
(p who v mode o (output-port/max-max-length o/m max-length) graph config)))
((custom-write-accessor v) v o/m mode)
(output-port/max-max-length o/m max-length))]
[(struct? v)
(cond
[(eq? mode PRINT-MODE/UNQUOTED)