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

cs: fix some predefined struct-operation procedure names

Browse Source 
Closes #3592
This commit is contained in:
Matthew Flatt 2020-12-30 04:54:06 -07:00
parent c7ca4414ca
commit dbe36162ac
2 changed files with 18 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -207,4 +207,11 @@
(test 'bytes-set! object-name bytes-set!) (test 'bytes-set! object-name bytes-set!)
(test 'bytes-length object-name bytes-length) (test 'bytes-length object-name bytes-length)
;; Check some primitive structure functions
(test 'date object-name date)
(test 'date* object-name date*)
(test 'date? object-name date?)
(test 'date*? object-name date*?)
(test 'date-second object-name date-second)
(report-errs) (report-errs)

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

@ -1282,16 +1282,20 @@
(define name ctr-expr) (define name ctr-expr)
(define authentic-name? (record-predicate struct:name)) (define authentic-name? (record-predicate struct:name))
(define name? (|#%struct-predicate| (define name? (|#%struct-predicate|
(lambda (v) (or (authentic-name? v) (|#%name|
(and (impersonator? v) name?
(authentic-name? (impersonator-val v))))))) (lambda (v) (or (authentic-name? v)
(and (impersonator? v)
(authentic-name? (impersonator-val v))))))))
(define name-field (define name-field
(let ([name-field (record-accessor struct:name field-index)]) (let ([name-field (record-accessor struct:name field-index)])
(|#%struct-field-accessor| (|#%struct-field-accessor|
(lambda (v) (|#%name|
(if (authentic-name? v) name-field
(name-field v) (lambda (v)
(pariah (impersonate-ref name-field struct:name field-index v 'name 'field)))) (if (authentic-name? v)
(name-field v)
(pariah (impersonate-ref name-field struct:name field-index v 'name 'field)))))
struct:name struct:name
field-index))) field-index)))
... ...