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

cs: fix mutability check on prefab auto fields

Browse Source 
Also, fix the error message for misuse of a mutator.
This commit is contained in:
Matthew Flatt 2020-06-24 06:06:46 -06:00
parent 7578e8e083
commit 27fd176968
4 changed files with 39 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1286,6 +1286,29 @@
(-set! v 3 'ok)
(test 'ok -ref v 3))
;; ----------------------------------------
;; Check that prefab auto fields count as mutable
(let ()
(struct flag ([x #:auto #:mutable]) #:prefab)
(define f (flag))
(set-flag-x! f 'ok)
(test 'ok flag-x f)
(err/rt-test (set-flag-x! 'no 'way) exn:fail:contract? #rx"^set-flag-x!:")
(define f2 (read (open-input-string "#s((flag (1 #f)) #f)")))
(test #f flag-x f2)
(set-flag-x! f2 'ok)
(test 'ok flag-x f2)
(struct flag-3d flag (y [z #:auto #:mutable]) #:prefab)
(define f3 (flag-3d 'y))
(set-flag-x! f3 'three)
(test 'three flag-x f3)
(set-flag-3d-z! f3 'zee)
(test 'zee flag-3d-z f3))
;; ----------------------------------------
;; Make sure that a JIT-inlined predicate doesn't
;; fail improperly on chaperones and struct types

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

@ -139,10 +139,12 @@
(unsafe-struct*-set! v abs-pos a)])))]
[else
(raise-argument-error (string->symbol
(string-append "set"
(string-append "set-"
(symbol->string (or record-name 'struct))
"-"
(symbol->string (or field-name 'field))
(if field-name
(symbol->string field-name)
(string-append "field" (number->string pos)))
"!"))
(string-append (symbol->string (or record-name 'struct)) "?")
orig)]))

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

@ -313,7 +313,7 @@
vec
(list->vector
(append (vector->list vec)
(let loop ([auto auto] [pos (fx- init+auto-count auto 1)])
(let loop ([auto auto] [pos (fx- init+auto-count auto)])
(if (fx= auto 0)
'()
(cons pos (loop (fx- auto 1) (fx+ pos 1))))))))))

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

@ -750,24 +750,24 @@
(let* ([abs-pos (+ pos (position-based-mutator-offset pbm))]
[p (record-field-mutator rtd abs-pos)]
[rec-name (record-type-name rtd)]
[name (string->symbol
(string-append "set-"
(symbol->string rec-name)
"-"
(if name
(symbol->string name)
(string-append "field" (number->string pos)))
"!"))]
[mut-name (string->symbol
(string-append "set-"
(symbol->string rec-name)
"-"
(if name
(symbol->string name)
(string-append "field" (number->string pos)))
"!"))]
[wrap-p
(procedure-rename
(if (struct-type-field-mutable? rtd pos)
(lambda (v a)
(if (record? v rtd)
(p v a)
(impersonate-set! p rtd pos abs-pos v a rec-name (or name 'field))))
(impersonate-set! p rtd pos abs-pos v a rec-name name)))
(lambda (v a)
(cannot-modify-by-pos-error name v pos)))
name)])
(cannot-modify-by-pos-error mut-name v pos)))
mut-name)])
(register-struct-field-mutator! wrap-p rtd pos)
wrap-p))]
[(pbm pos)