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

cs: fix structure property accessor & predicate names

Browse Source
This commit is contained in:
Matthew Flatt 2020-02-08 08:25:12 -07:00
parent e4c5d54e37
commit 7f729a1a2b
1 changed files with 30 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -80,33 +80,36 @@
[(procedure? fail) (|#%app| fail)] [(procedure? fail) (|#%app| fail)]
[else fail]))]) [else fail]))])
(letrec ([acc (letrec ([acc
(case-lambda (procedure-rename
[(v fail) (case-lambda
(cond [(v fail)
[(and (impersonator? v) (cond
(pred v)) [(and (impersonator? v)
(impersonate-struct-or-property-ref acc #f #|key1:|# acc #|key2:|# #f v #f #f)] (pred v))
[else (impersonate-struct-or-property-ref acc #f #|key1:|# acc #|key2:|# #f v #f #f)]
(let* ([rtd (if (record-type-descriptor? v) [else
v (let* ([rtd (if (record-type-descriptor? v)
(and (record? v) v
(record-rtd v)))]) (and (record? v)
(if rtd (record-rtd v)))])
(let ([pv (struct-property-ref st rtd none)]) (if rtd
(if (eq? pv none) (let ([pv (struct-property-ref st rtd none)])
(do-fail fail v) (if (eq? pv none)
pv)) (do-fail fail v)
(do-fail fail v)))])] pv))
[(v) (acc v default-fail)])]) (do-fail fail v)))])]
(add-to-table! property-accessors [(v) (acc v default-fail)])
acc accessor-name)])
(cons pred can-impersonate?)) (let ([pred (procedure-rename pred predicate-name)])
(add-to-table! property-predicates (add-to-table! property-accessors
pred acc
st) (cons pred can-impersonate?))
(values st (add-to-table! property-predicates
pred pred
acc)))])) st)
(values st
pred
acc))))]))
(define (struct-type-property-accessor-procedure? v) (define (struct-type-property-accessor-procedure? v)
(let ([v (strip-impersonator v)]) (let ([v (strip-impersonator v)])