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