cs: fix struct constructor result for object-name
This commit is contained in:
Matthew Flatt
parent
55728352f4
commit
541a8e870f
|
|
@ -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?)"))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user