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

cs: fix internal issues in struct [property] layer

Browse Source
This commit is contained in:
Matthew Flatt 2020-02-09 18:27:14 -07:00
parent fd9a5f0357
commit e8fa0613db
2 changed files with 23 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
racket/src/cs/rumble/procedure.ss
View File

@ -449,6 +449,7 @@
(do-procedure-reduce-arity-mask proc mask name)] (do-procedure-reduce-arity-mask proc mask name)]
[(proc mask) (procedure-reduce-arity-mask proc mask #f)])) [(proc mask) (procedure-reduce-arity-mask proc mask #f)]))
;; see also `procedure-rename*` in "struct.ss"
(define (do-procedure-reduce-arity-mask proc mask name) (define (do-procedure-reduce-arity-mask proc mask name)
(cond (cond
[(and (wrapper-procedure? proc) [(and (wrapper-procedure? proc)

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

@ -41,14 +41,13 @@
(and (procedure? guard) (and (procedure? guard)
(procedure-arity-includes? guard 2))) (procedure-arity-includes? guard 2)))
(raise-argument-error who "(or/c (procedure-arity-includes/c 2) #f 'can-impersonate)" guard)) (raise-argument-error who "(or/c (procedure-arity-includes/c 2) #f 'can-impersonate)" guard))
(unless (and (or (null? supers) ; avoid `list?` until it's defined (unless (and (#%list? supers)
(list? supers)) (#%andmap (lambda (p)
(andmap (lambda (p) (and (pair? p)
(and (pair? p) (struct-type-property? (car p))
(struct-type-property? (car p)) (procedure? (cdr p))
(procedure? (cdr p)) (procedure-arity-includes? (cdr p) 1)))
(procedure-arity-includes? (cdr p) 1))) supers))
supers))
(raise-argument-error who "(listof (cons/c struct-type-property? (procedure-arity-includes/c 1)))" supers)) (raise-argument-error who "(listof (cons/c struct-type-property? (procedure-arity-includes/c 1)))" supers))
(let* ([can-impersonate? (and (or can-impersonate? (eq? guard 'can-impersonate)) #t)] (let* ([can-impersonate? (and (or can-impersonate? (eq? guard 'can-impersonate)) #t)]
[st (make-struct-type-prop name (and (not (eq? guard 'can-impersonate)) guard) supers)] [st (make-struct-type-prop name (and (not (eq? guard 'can-impersonate)) guard) supers)]
@ -80,7 +79,7 @@
[(procedure? fail) (|#%app| fail)] [(procedure? fail) (|#%app| fail)]
[else fail]))]) [else fail]))])
(letrec ([acc (letrec ([acc
(procedure-rename (procedure-rename*
(case-lambda (case-lambda
[(v fail) [(v fail)
(cond (cond
@ -99,8 +98,9 @@
pv)) pv))
(do-fail fail v)))])] (do-fail fail v)))])]
[(v) (acc v default-fail)]) [(v) (acc v default-fail)])
6
accessor-name)]) accessor-name)])
(let ([pred (procedure-rename pred predicate-name)]) (let ([pred (procedure-rename* pred 2 predicate-name)])
(add-to-table! property-accessors (add-to-table! property-accessors
acc acc
(cons pred can-impersonate?)) (cons pred can-impersonate?))
@ -141,6 +141,13 @@
(define (struct-property-set! prop rtd val) (define (struct-property-set! prop rtd val)
(putprop (record-type-uid rtd) prop val)) (putprop (record-type-uid rtd) prop val))
;; Must be consistent with `procedure-rename` in "procedure.ss",
;; but needed before that one is defined:
(define (procedure-rename* proc mask name)
(make-arity-wrapper-procedure proc
mask
(vector name proc)))
;; ---------------------------------------- ;; ----------------------------------------
(define-record-type (inspector new-inspector inspector?) (define-record-type (inspector new-inspector inspector?)
@ -194,9 +201,9 @@
:contract "(or/c procedure? exact-nonnegative-integer? #f)" :contract "(or/c procedure? exact-nonnegative-integer? #f)"
proc-spec) proc-spec)
(check who (check who
:test (and (list props) :test (and (#%list? props)
(andmap (lambda (i) (and (pair? i) (struct-type-property? (car i)))) (#%andmap (lambda (i) (and (pair? i) (struct-type-property? (car i))))
props)) props))
:contract "(listof (cons/c struct-type-property? any/c))" :contract "(listof (cons/c struct-type-property? any/c))"
props) props)
(check who (check who
@ -206,8 +213,8 @@
:contract "(or/c inspector? #f 'prefab)" :contract "(or/c inspector? #f 'prefab)"
insp) insp)
(check who (check who
:test (and (list? immutables) :test (and (#%list? immutables)
(andmap exact-nonnegative-integer? immutables)) (#%andmap exact-nonnegative-integer? immutables))
:contract "(listof exact-nonnegative-integer?)" :contract "(listof exact-nonnegative-integer?)"
immutables) immutables)
(check who :or-false procedure? guard) (check who :or-false procedure? guard)