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

cs: fix struct constructor result for object-name

Browse Source
This commit is contained in:
Matthew Flatt 2019-05-20 06:33:33 -06:00
parent 55728352f4
commit 541a8e870f
5 changed files with 59 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -124,6 +124,9 @@
(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 "mk-CP")
object-name
(eval (read (open-input-string "(let () (struct CP (a) #:constructor-name mk-CP) mk-CP)"))))
(test (string->symbol "CP?") (test (string->symbol "CP?")
object-name object-name
(eval (read (open-input-string "(let () (define-struct CP (a)) CP?)")))) (eval (read (open-input-string "(let () (define-struct CP (a)) CP?)"))))

10
racket/src/cs/convert.rkt
View File

@ -8,7 +8,8 @@
"../schemify/schemify.rkt" "../schemify/schemify.rkt"
"../schemify/serialize.rkt" "../schemify/serialize.rkt"
"../schemify/known.rkt" "../schemify/known.rkt"
"../schemify/lift.rkt") "../schemify/lift.rkt"
"../schemify/wrap.rkt")
(define skip-export? #f) (define skip-export? #f)
(define for-cify? #f) (define for-cify? #f)
@ -208,6 +209,13 @@
;; in general. ;; in general.
(define (rename-functions e) (define (rename-functions e)
(cond (cond
[(wrap? e)
(cond
[(wrap-property e 'inferred-name)
=> (lambda (name)
`(#%name ,name ,(rename-functions (unwrap e))))]
[else
(rename-functions (unwrap e))])]
[(not (pair? e)) e] [(not (pair? e)) e]
[else [else
(define (begin-name e) (define (begin-name e)

51
racket/src/schemify/struct-convert.rkt
View File

@ -64,12 +64,25 @@
,@(schemify-body schemify knowns (struct-type-info-rest sti)))))) ,@(schemify-body schemify knowns (struct-type-info-rest sti))))))
(define ,make-s ,(let ([ctr `(record-constructor (define ,make-s ,(let ([ctr `(record-constructor
(make-record-constructor-descriptor ,struct:s #f #f))]) (make-record-constructor-descriptor ,struct:s #f #f))])
(if (struct-type-info-pure-constructor? sti) (define ctr-expr
ctr (if (struct-type-info-pure-constructor? sti)
`(struct-type-constructor-add-guards ,ctr ,struct:s ',(struct-type-info-name sti))))) ctr
`(struct-type-constructor-add-guards ,ctr ,struct:s ',(struct-type-info-name sti))))
(define name-expr (struct-type-info-constructor-name-expr sti))
(match name-expr
[`#f
(wrap-property-set ctr-expr 'inferred-name (struct-type-info-name sti))]
[`',sym
(if (symbol? sym)
(wrap-property-set ctr-expr 'inferred-name sym)
`(procedure-rename ,ctr-expr ,name-expr))]
[`,_
`(procedure-rename ,ctr-expr ,name-expr)])))
(define ,raw-s? (record-predicate ,struct:s)) (define ,raw-s? (record-predicate ,struct:s))
,@(if can-impersonate? ,@(if can-impersonate?
`((define ,s? (lambda (v) (if (,raw-s? v) #t ($value (if (impersonator? v) (,raw-s? (impersonator-val v)) #f)))))) `((define ,s? ,(name-procedure
"" (struct-type-info-name sti) "" '|| "?"
`(lambda (v) (if (,raw-s? v) #t ($value (if (impersonator? v) (,raw-s? (impersonator-val v)) #f)))))))
null) null)
,@(for/list ([acc/mut (in-list acc/muts)] ,@(for/list ([acc/mut (in-list acc/muts)]
[make-acc/mut (in-list make-acc/muts)]) [make-acc/mut (in-list make-acc/muts)])
@ -81,10 +94,12 @@
`(begin `(begin
,raw-def ,raw-def
(define ,acc/mut (define ,acc/mut
(lambda (s) (if (,raw-s? s) ,(name-procedure
(,raw-acc/mut s) "" (struct-type-info-name sti) "-" field-name ""
($value (impersonate-ref ,raw-acc/mut ,struct:s ,pos s `(lambda (s) (if (,raw-s? s)
',(struct-type-info-name sti) ',field-name)))))) (,raw-acc/mut s)
($value (impersonate-ref ,raw-acc/mut ,struct:s ,pos s
',(struct-type-info-name sti) ',field-name)))))))
raw-def)] raw-def)]
[`(make-struct-field-mutator ,(? (lambda (v) (wrap-eq? v -set!))) ,pos ',field-name) [`(make-struct-field-mutator ,(? (lambda (v) (wrap-eq? v -set!))) ,pos ',field-name)
(define raw-def `(define ,raw-acc/mut (record-mutator ,struct:s ,pos))) (define raw-def `(define ,raw-acc/mut (record-mutator ,struct:s ,pos)))
@ -94,10 +109,12 @@
`(begin `(begin
,raw-def ,raw-def
(define ,acc/mut (define ,acc/mut
(lambda (s v) (if (,raw-s? s) ,(name-procedure
(,raw-acc/mut s v) "set-" (struct-type-info-name sti) "-" field-name "!"
($value (impersonate-set! ,raw-acc/mut ,struct:s ,pos ,abs-pos s v `(lambda (s v) (if (,raw-s? s)
',(struct-type-info-name sti) ',field-name)))))) (,raw-acc/mut s v)
($value (impersonate-set! ,raw-acc/mut ,struct:s ,pos ,abs-pos s v
',(struct-type-info-name sti) ',field-name)))))))
raw-def)] raw-def)]
[`,_ (error "oops")])) [`,_ (error "oops")]))
(define ,(gensym) (define ,(gensym)
@ -161,3 +178,13 @@
(define (schemify-body schemify knowns l) (define (schemify-body schemify knowns l)
(for/list ([e (in-list l)]) (for/list ([e (in-list l)])
(schemify e knowns))) (schemify e knowns)))
(define (name-procedure pre st sep fld post proc-expr)
(wrap-property-set proc-expr
'inferred-name
(string->symbol
(string-append pre
(symbol->string st)
sep
(symbol->string fld)
post))))

4
racket/src/schemify/struct-type-info.rkt
View File

@ -18,6 +18,7 @@
pure-constructor? pure-constructor?
authentic? authentic?
prefab-immutables ; #f or immutable expression to be quoted prefab-immutables ; #f or immutable expression to be quoted
constructor-name-expr ; an expression
rest)) ; argument expressions after auto-field value rest)) ; argument expressions after auto-field value
(define struct-type-info-rest-properties-list-pos 0) (define struct-type-info-rest-properties-list-pos 0)
@ -58,6 +59,8 @@
(for/or ([prop (in-list props)]) (for/or ([prop (in-list props)])
(eq? (unwrap prop) name))] (eq? (unwrap prop) name))]
[`,_ #f]))) [`,_ #f])))
(define constructor-name-expr (and ((length rest) . > . 5)
(list-ref rest 5)))
(and prefab-imms (and prefab-imms
(struct-type-info name (struct-type-info name
parent parent
@ -75,6 +78,7 @@
(if (eq? prefab-imms 'non-prefab) (if (eq? prefab-imms 'non-prefab)
#f #f
prefab-imms) prefab-imms)
constructor-name-expr
rest)))))] rest)))))]
[`(let-values () ,body) [`(let-values () ,body)
(make-struct-type-info body prim-knowns knowns imports mutated)] (make-struct-type-info body prim-knowns knowns imports mutated)]

5
racket/src/schemify/wrap.rkt
View File

@ -84,7 +84,10 @@
(correlated-property a key))) (correlated-property a key)))
(define (wrap-property-set a key val) (define (wrap-property-set a key val)
(correlated-property a key val)) (let ([a (if (correlated? a)
a
(datum->correlated #f a #f #f))])
(correlated-property a key val)))
(define (wrap-source a) (define (wrap-source a)
(cond (cond