From 541a8e870f67ad3b8ead68e695d22feb77a574df Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 20 May 2019 06:33:33 -0600 Subject: [PATCH] cs: fix struct constructor result for `object-name` --- pkgs/racket-test-core/tests/racket/name.rktl | 3 ++ racket/src/cs/convert.rkt | 10 +++- racket/src/schemify/struct-convert.rkt | 51 +++++++++++++++----- racket/src/schemify/struct-type-info.rkt | 4 ++ racket/src/schemify/wrap.rkt | 5 +- 5 files changed, 59 insertions(+), 14 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/name.rktl b/pkgs/racket-test-core/tests/racket/name.rktl index 547d907b23..5ffa22b954 100644 --- a/pkgs/racket-test-core/tests/racket/name.rktl +++ b/pkgs/racket-test-core/tests/racket/name.rktl @@ -124,6 +124,9 @@ (test (string->symbol "CP") object-name (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?") object-name (eval (read (open-input-string "(let () (define-struct CP (a)) CP?)")))) diff --git a/racket/src/cs/convert.rkt b/racket/src/cs/convert.rkt index bfff517f58..be749b51bc 100644 --- a/racket/src/cs/convert.rkt +++ b/racket/src/cs/convert.rkt @@ -8,7 +8,8 @@ "../schemify/schemify.rkt" "../schemify/serialize.rkt" "../schemify/known.rkt" - "../schemify/lift.rkt") + "../schemify/lift.rkt" + "../schemify/wrap.rkt") (define skip-export? #f) (define for-cify? #f) @@ -208,6 +209,13 @@ ;; in general. (define (rename-functions e) (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] [else (define (begin-name e) diff --git a/racket/src/schemify/struct-convert.rkt b/racket/src/schemify/struct-convert.rkt index ce7b5822df..02497d957a 100644 --- a/racket/src/schemify/struct-convert.rkt +++ b/racket/src/schemify/struct-convert.rkt @@ -64,12 +64,25 @@ ,@(schemify-body schemify knowns (struct-type-info-rest sti)))))) (define ,make-s ,(let ([ctr `(record-constructor (make-record-constructor-descriptor ,struct:s #f #f))]) - (if (struct-type-info-pure-constructor? sti) - ctr - `(struct-type-constructor-add-guards ,ctr ,struct:s ',(struct-type-info-name sti))))) + (define ctr-expr + (if (struct-type-info-pure-constructor? 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)) ,@(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) ,@(for/list ([acc/mut (in-list acc/muts)] [make-acc/mut (in-list make-acc/muts)]) @@ -81,10 +94,12 @@ `(begin ,raw-def (define ,acc/mut - (lambda (s) (if (,raw-s? s) - (,raw-acc/mut s) - ($value (impersonate-ref ,raw-acc/mut ,struct:s ,pos s - ',(struct-type-info-name sti) ',field-name)))))) + ,(name-procedure + "" (struct-type-info-name sti) "-" field-name "" + `(lambda (s) (if (,raw-s? s) + (,raw-acc/mut s) + ($value (impersonate-ref ,raw-acc/mut ,struct:s ,pos s + ',(struct-type-info-name sti) ',field-name))))))) raw-def)] [`(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))) @@ -94,10 +109,12 @@ `(begin ,raw-def (define ,acc/mut - (lambda (s v) (if (,raw-s? s) - (,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)))))) + ,(name-procedure + "set-" (struct-type-info-name sti) "-" field-name "!" + `(lambda (s v) (if (,raw-s? s) + (,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)] [`,_ (error "oops")])) (define ,(gensym) @@ -161,3 +178,13 @@ (define (schemify-body schemify knowns l) (for/list ([e (in-list l)]) (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)))) diff --git a/racket/src/schemify/struct-type-info.rkt b/racket/src/schemify/struct-type-info.rkt index 421820ac5d..e6b9fb4b43 100644 --- a/racket/src/schemify/struct-type-info.rkt +++ b/racket/src/schemify/struct-type-info.rkt @@ -18,6 +18,7 @@ pure-constructor? authentic? prefab-immutables ; #f or immutable expression to be quoted + constructor-name-expr ; an expression rest)) ; argument expressions after auto-field value (define struct-type-info-rest-properties-list-pos 0) @@ -58,6 +59,8 @@ (for/or ([prop (in-list props)]) (eq? (unwrap prop) name))] [`,_ #f]))) + (define constructor-name-expr (and ((length rest) . > . 5) + (list-ref rest 5))) (and prefab-imms (struct-type-info name parent @@ -75,6 +78,7 @@ (if (eq? prefab-imms 'non-prefab) #f prefab-imms) + constructor-name-expr rest)))))] [`(let-values () ,body) (make-struct-type-info body prim-knowns knowns imports mutated)] diff --git a/racket/src/schemify/wrap.rkt b/racket/src/schemify/wrap.rkt index adb76bd623..2b251d8c39 100644 --- a/racket/src/schemify/wrap.rkt +++ b/racket/src/schemify/wrap.rkt @@ -84,7 +84,10 @@ (correlated-property a key))) (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) (cond