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

cs: fix struct proc names from make-struct-type

Browse Source
This commit is contained in:
Matthew Flatt 2019-01-14 09:28:10 -07:00
parent 40bc59d512
commit ad2c0624b5
2 changed files with 48 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
pkgs/racket-test-core/tests/racket/name.rktl
View File

@ -105,7 +105,16 @@
(eval (read (open-input-string "(let ([Capital (lambda () 10)]) Capital)"))))
(test (string->symbol "CP")
object-name
(eval (read (open-input-string "(let () (define-struct CP (a)) make-CP)")))))
(eval (read (open-input-string "(let () (define-struct CP (a)) make-CP)"))))
(test (string->symbol "CP?")
object-name
(eval (read (open-input-string "(let () (define-struct CP (a)) CP?)"))))
(test (string->symbol "CP-a")
object-name
(eval (read (open-input-string "(let () (define-struct CP (a)) CP-a)"))))
(test (string->symbol "set-CP-a!")
object-name
(eval (read (open-input-string "(let () (define-struct CP ([a #:mutable])) set-CP-a!)")))))
(err/rt-test (let ([unmentionable ((lambda (x #:a a) 1) 1 2)]) 5)

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

@ -464,21 +464,22 @@
install-props!)
(let ([ctr (struct-type-constructor-add-guards
(let ([c (record-constructor rtd)])
(if (zero? auto*-count)
c
(procedure-rename
(procedure-rename
(if (zero? auto*-count)
c
(procedure-reduce-arity
(lambda args
(apply c (reverse (auto-field-adder (reverse args)))))
init*-count)
(or constructor-name name))))
init*-count))
(or constructor-name name)))
rtd
(or constructor-name name))]
[pred (escapes-ok
(lambda (v)
(or (record? v rtd)
(and (impersonator? v)
(record? (impersonator-val v) rtd)))))])
[pred (procedure-rename
(lambda (v)
(or (record? v rtd)
(and (impersonator? v)
(record? (impersonator-val v) rtd))))
(string->symbol (string-append (symbol->string name) "?")))])
(register-struct-constructor! ctr)
(register-struct-constructor! pred)
(values rtd
@ -649,11 +650,16 @@
(let* ([p (record-field-accessor rtd
(+ pos (position-based-accessor-offset pba)))]
[wrap-p
(escapes-ok
(procedure-rename
(lambda (v)
(if (impersonator? v)
(impersonate-ref p rtd pos v)
(p v))))])
(p v)))
(string->symbol (string-append (symbol->string (record-type-name rtd))
"-"
(if name
(symbol->string name)
(string-append "field" (number->string pos))))))])
(register-struct-field-accessor! wrap-p rtd pos)
wrap-p))]
[(pba pos)
@ -671,23 +677,27 @@
(check-accessor-or-mutator-index who rtd pos)
(let* ([abs-pos (+ pos (position-based-mutator-offset pbm))]
[p (record-field-mutator rtd abs-pos)]
[name (string->symbol
(string-append "set-"
(symbol->string (record-type-name rtd))
"-"
(if name
(symbol->string name)
(string-append "field" (number->string pos)))
"!"))]
[wrap-p
(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)))])
(procedure-rename
(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 name
"cannot modify value of immutable field in structure"
"structure" v
"field index" pos)))
name)])
(register-struct-field-mutator! wrap-p rtd pos)
wrap-p))]
[(pbm pos)