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

Implement lazy signature checking for ordinary pairs.

Browse Source
This commit is contained in:
Mike Sperber 2010-09-22 11:03:01 +02:00
parent b9155b8c5f
commit 593f8588fe
4 changed files with 204 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/deinprogramm/define-record-procedures.scm
View File

@ -65,7 +65,7 @@
(format "~a: Argument kein ~a: ~e" (format "~a: Argument kein ~a: ~e"
'tag '?type-name s)) 'tag '?type-name s))
(current-continuation-marks)))) (current-continuation-marks))))
(check-struct-wraps! s) (check-lazy-wraps! type-descriptor s)
(raw-generic-access s i))) (raw-generic-access s i)))
'inferred-name 'inferred-name
(syntax-e accessor)))) (syntax-e accessor))))
@ -184,7 +184,10 @@
component-signature ...))) component-signature ...)))
;; lazy signatures ;; lazy signatures
#'(define (?signature-constructor-name ?param ...) #'(define (?signature-constructor-name ?param ...)
(make-struct-wrap-signature '?type-name type-descriptor (list ?param ...) #'?type-name))) (make-lazy-wrap-signature '?type-name
type-descriptor raw-predicate
(list ?param ...)
#'?type-name)))
'stepper-skip-completely 'stepper-skip-completely
#t))) #t)))
#'(begin #'(begin

289
collects/deinprogramm/signature/signature.rkt
View File

@ -22,8 +22,9 @@
procedure-signature-info-arg-signatures procedure-signature-info-return-signature procedure-signature-info-arg-signatures procedure-signature-info-return-signature
make-lazy-wrap-info lazy-wrap-info-constructor lazy-wrap-info-raw-accessors make-lazy-wrap-info lazy-wrap-info-constructor lazy-wrap-info-raw-accessors
prop:lazy-wrap lazy-wrap? lazy-wrap-ref prop:lazy-wrap lazy-wrap? lazy-wrap-ref
make-struct-wrap-signature make-lazy-wrap-signature
check-struct-wraps! check-lazy-wraps!
make-pair-signature checked-car checked-cdr
signature=? signature<=?) signature=? signature<=?)
(require scheme/promise (require scheme/promise
@ -304,11 +305,11 @@
sigs2)) sigs2))
sigs1)) sigs1))
; Flatten out mixed signatures, and fold in in the struct-wrap ; Flatten out mixed signatures, and fold in in the lazy-wrap
; signatures ; signatures
(define (normalize-mixed-signatures mixed-signature sigs) (define (normalize-mixed-signatures mixed-signature sigs)
(fold-struct-wrap-signatures mixed-signature (flatten-mixed-signatures sigs))) (fold-lazy-wrap-signatures mixed-signature (flatten-mixed-signatures sigs)))
(define (flatten-mixed-signatures sigs) (define (flatten-mixed-signatures sigs)
(apply append (apply append
@ -472,9 +473,9 @@
#:transparent) #:transparent)
; This situation makes trouble: ; This situation makes trouble:
; (make-mixed-signature (make-struct-wrap-signature ...) (make-struct-wrap-signature ...) ...) ; (make-mixed-signature (make-lazy-wrap-signature ...) (make-lazy-wrap-signature ...) ...)
; We need to push the `mixed' signature inside the struct-wrap ; We need to push the `mixed' signature inside the lazy-wrap
; signature, which is why the struct-map signature has an implicit ; signature, which is why the struct-map signature has an implicit
; `mixed'. ; `mixed'.
; To this end, a `lazy-log-not-checked' object tracks a list of ; To this end, a `lazy-log-not-checked' object tracks a list of
@ -485,107 +486,102 @@
(mixed-signature field-signatures-list) (mixed-signature field-signatures-list)
#:transparent) #:transparent)
(define (make-struct-wrap-signature name type-descriptor field-signatures syntax) (define (make-lazy-wrap-signature name type-descriptor predicate field-signatures syntax)
(really-make-struct-wrap-signature name type-descriptor #f (list field-signatures) syntax)) (really-make-lazy-wrap-signature name type-descriptor predicate #f (list field-signatures) syntax))
; The lists of signatures in `field-signatures-list' form an implicit mixed signature. ; The lists of signatures in `field-signatures-list' form an implicit mixed signature.
(define (really-make-struct-wrap-signature name type-descriptor (define (really-make-lazy-wrap-signature name type-descriptor predicate
mixed-signature field-signatures-list mixed-signature field-signatures-list
syntax) syntax)
(let ((lazy-wrap-info (lazy-wrap-ref type-descriptor)) (let ((lazy-wrap-info (lazy-wrap-ref type-descriptor))
(not-checked (make-lazy-log-not-checked mixed-signature field-signatures-list)) (not-checked (make-lazy-log-not-checked mixed-signature field-signatures-list))
(struct-wrap-info (make-struct-wrap-info type-descriptor field-signatures-list)) (lazy-wrap-signature-info (make-lazy-wrap-signature-info type-descriptor predicate field-signatures-list)))
(predicate (lambda (thing)
(and (struct? thing)
(let-values (((thing-descriptor _) (struct-info thing)))
(eq? thing-descriptor type-descriptor))))))
(let ((constructor (lazy-wrap-info-constructor lazy-wrap-info)) (let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info)) (raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))
(wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info)) (wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info))
(wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info))) (wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info)))
(make-signature (make-signature
name name
(lambda (self thing) (lambda (self thing)
(if (not (predicate thing)) (if (not (predicate thing))
(signature-violation thing self #f #f) (signature-violation thing self #f #f)
(let ((log (wrap-ref thing))) (let ((log (wrap-ref thing)))
(cond (cond
((not log) ((not log)
(wrap-set! thing (wrap-set! thing
(make-lazy-wrap-log (list not-checked) '()))) (make-lazy-wrap-log (list not-checked) '())))
((not (let () ((not (let ()
(define (<=? sigs1 sigs2) (define (<=? sigs1 sigs2)
(andmap signature<=? sigs1 sigs2)) (andmap signature<=? sigs1 sigs2))
(define (check wrap-field-signatures) (define (check wrap-field-signatures)
(ormap (lambda (field-signatures) (ormap (lambda (field-signatures)
(<=? wrap-field-signatures field-signatures)) (<=? wrap-field-signatures field-signatures))
field-signatures-list)) field-signatures-list))
(or (ormap (lambda (wrap-not-checked) (or (ormap (lambda (wrap-not-checked)
(andmap check (andmap check
(lazy-log-not-checked-field-signatures-list wrap-not-checked))) (lazy-log-not-checked-field-signatures-list wrap-not-checked)))
(lazy-wrap-log-not-checked log)) (lazy-wrap-log-not-checked log))
(ormap check (lazy-wrap-log-checked log))))) (ormap check (lazy-wrap-log-checked log)))))
(wrap-set! thing (wrap-set! thing
(make-lazy-wrap-log (cons not-checked (lazy-wrap-log-not-checked log)) (make-lazy-wrap-log (cons not-checked (lazy-wrap-log-not-checked log))
(lazy-wrap-log-checked log))))))) (lazy-wrap-log-checked log)))))))
thing) thing)
(delay syntax) (delay syntax)
#:info-promise #:info-promise
(delay struct-wrap-info) (delay lazy-wrap-signature-info)
#:=?-proc #:=?-proc
(lambda (this-info other-info) (lambda (this-info other-info)
(and (struct-wrap-info? other-info) (and (lazy-wrap-signature-info? other-info)
(struct-wrap-info-field-signatures-list other-info) (lazy-wrap-signature-info-field-signatures-list other-info)
(eq? type-descriptor (struct-wrap-info-descriptor other-info)) (eq? type-descriptor (lazy-wrap-signature-info-descriptor other-info))
(andmap (lambda (this-field-signatures) (andmap (lambda (this-field-signatures)
(andmap (lambda (other-field-signatures) (andmap (lambda (other-field-signatures)
(andmap signature=? this-field-signatures other-field-signatures)) (andmap signature=? this-field-signatures other-field-signatures))
(struct-wrap-info-field-signatures-list other-info))) (lazy-wrap-signature-info-field-signatures-list other-info)))
(struct-wrap-info-field-signatures-list this-info)))) (lazy-wrap-signature-info-field-signatures-list this-info))))
#:<=?-proc #:<=?-proc
(lambda (this-info other-info) (lambda (this-info other-info)
(and (struct-wrap-info? other-info) (and (lazy-wrap-signature-info? other-info)
(struct-wrap-info-field-signatures-list other-info) (lazy-wrap-signature-info-field-signatures-list other-info)
(eq? type-descriptor (struct-wrap-info-descriptor other-info)) (eq? type-descriptor (lazy-wrap-signature-info-descriptor other-info))
(andmap (lambda (this-field-signatures) (andmap (lambda (this-field-signatures)
(ormap (lambda (other-field-signatures) (ormap (lambda (other-field-signatures)
(andmap signature<=? this-field-signatures other-field-signatures)) (andmap signature<=? this-field-signatures other-field-signatures))
(struct-wrap-info-field-signatures-list other-info))) (lazy-wrap-signature-info-field-signatures-list other-info)))
(struct-wrap-info-field-signatures-list this-info)))))))) (lazy-wrap-signature-info-field-signatures-list this-info))))))))
(define-struct struct-wrap-info (descriptor field-signatures-list) #:transparent) (define-struct lazy-wrap-signature-info (descriptor predicate field-signatures-list) #:transparent)
(define (check-struct-wraps! thing) (define (check-lazy-wraps! descriptor thing)
(let-values (((descriptor skipped?) (struct-info thing))) (let ((lazy-wrap-info (lazy-wrap-ref descriptor)))
(let ((lazy-wrap-info (lazy-wrap-ref descriptor)))
(let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))
(raw-mutators (lazy-wrap-info-raw-mutators lazy-wrap-info))
(wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info))
(wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info)))
(let ((log (wrap-ref thing))) (let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
(when (and log (pair? (lazy-wrap-log-not-checked log))) (raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))
(let loop ((field-vals (map (lambda (raw-accessor) (raw-mutators (lazy-wrap-info-raw-mutators lazy-wrap-info))
(raw-accessor thing)) (wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info))
raw-accessors)) (wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info)))
(now-checked '())
(not-checkeds (lazy-wrap-log-not-checked log))) (let ((log (wrap-ref thing)))
(if (null? not-checkeds) (when (and log (pair? (lazy-wrap-log-not-checked log)))
(begin (let loop ((field-vals (map (lambda (raw-accessor)
(for-each (lambda (raw-mutator field-val) (raw-accessor thing))
(raw-mutator thing field-val)) raw-accessors))
raw-mutators field-vals) (now-checked '())
(wrap-set! thing (not-checkeds (lazy-wrap-log-not-checked log)))
(make-lazy-wrap-log '() (if (null? not-checkeds)
(append now-checked (begin
(lazy-wrap-log-checked log))))) (for-each (lambda (raw-mutator field-val)
(let ((not-checked (car not-checkeds))) (raw-mutator thing field-val))
(let ((field-signatures-list (lazy-log-not-checked-field-signatures-list not-checked)) raw-mutators field-vals)
(mixed-signature (lazy-log-not-checked-mixed-signature not-checked))) (wrap-set! thing
(make-lazy-wrap-log '()
(append now-checked
(lazy-wrap-log-checked log)))))
(let ((not-checked (car not-checkeds)))
(let ((field-signatures-list (lazy-log-not-checked-field-signatures-list not-checked))
(mixed-signature (lazy-log-not-checked-mixed-signature not-checked)))
(if (not mixed-signature) ; one-element list (if (not mixed-signature) ; one-element list
(loop (map apply-signature (car field-signatures-list) field-vals) (loop (map apply-signature (car field-signatures-list) field-vals)
(cons (car field-signatures-list) now-checked) (cons (car field-signatures-list) now-checked)
@ -607,34 +603,35 @@
(cdr field-vals) (cdr field-vals)
(cons new-val new-field-vals))) (cons new-val new-field-vals)))
(lambda () (lambda ()
(inner (cdr field-signatures-list))))))))))))))))))) (inner (cdr field-signatures-list))))))))))))))))))
; pushes down mixed contracts ; pushes down mixed contracts
(define (fold-struct-wrap-signatures mixed-signature sigs) (define (fold-lazy-wrap-signatures mixed-signature sigs)
(let ((struct-wrap-sigs (make-hasheq))) ; maps a type descriptor to signatures (let ((lazy-wrap-sigs (make-hasheq))) ; maps a type descriptor to signatures
(define (push-down-struct-wrap-sigs) (define (push-down-lazy-wrap-sigs)
(hash-map struct-wrap-sigs (hash-map lazy-wrap-sigs
(lambda (type-desc signatures) (lambda (type-desc signatures)
(really-make-struct-wrap-signature (really-make-lazy-wrap-signature
(signature-name (car signatures)) type-desc (signature-name (car signatures)) type-desc
(lazy-wrap-signature-info-predicate (real-signature-info (car signatures)))
mixed-signature mixed-signature
(apply append (apply append
(map (lambda (sig) (map (lambda (sig)
(struct-wrap-info-field-signatures-list (real-signature-info sig))) (lazy-wrap-signature-info-field-signatures-list (real-signature-info sig)))
signatures)) signatures))
(signature-syntax (car signatures)))))) (signature-syntax (car signatures))))))
(let loop ((sigs sigs) (let loop ((sigs sigs)
(vanilla-sigs '())) (vanilla-sigs '()))
(if (null? sigs) (if (null? sigs)
(append (push-down-struct-wrap-sigs) (append (push-down-lazy-wrap-sigs)
(reverse vanilla-sigs)) (reverse vanilla-sigs))
(let* ((sig (car sigs)) (let* ((sig (car sigs))
(info (real-signature-info sig))) (info (real-signature-info sig)))
(if (struct-wrap-info? info) (if (lazy-wrap-signature-info? info)
(let ((type-desc (struct-wrap-info-descriptor info))) (let ((type-desc (lazy-wrap-signature-info-descriptor info)))
(hash-update! struct-wrap-sigs (hash-update! lazy-wrap-sigs
type-desc type-desc
(lambda (old) (lambda (old)
(cons sig old)) (cons sig old))
@ -643,6 +640,88 @@
(loop (cdr sigs) vanilla-sigs)) (loop (cdr sigs) vanilla-sigs))
(loop (cdr sigs) (cons sig vanilla-sigs)))))))) (loop (cdr sigs) (cons sig vanilla-sigs))))))))
(define checked-pair-table (make-weak-hasheq))
(define-struct checked-pair
(car cdr log)
#:mutable)
(define (checked-pair-access checked-access raw-access)
(lambda (p)
(cond
((hash-ref checked-pair-table
p
(lambda () #f))
=> checked-access)
(else (raw-access p)))))
(define checked-raw-car (checked-pair-access checked-pair-car car))
(define checked-raw-cdr (checked-pair-access checked-pair-cdr cdr))
(define (checked-raw-set! checked-set!)
(lambda (p new)
(cond
((hash-ref checked-pair-table
p
(lambda () #f))
=> (lambda (cp)
(checked-set! cp new)))
(else
(let ((cp (make-checked-pair (car p) (cdr p) #f)))
(checked-set! cp new)
(hash-set! checked-pair-table p cp))))))
(define checked-raw-set-car! (checked-raw-set! set-checked-pair-car!))
(define checked-raw-set-cdr! (checked-raw-set! set-checked-pair-cdr!))
(define (checked-pair-get-log p)
(cond
((hash-ref checked-pair-table
p
(lambda () #f))
=> checked-pair-log)
(else #f)))
(define (checked-pair-set-log! p new)
(cond
((hash-ref checked-pair-table
p
(lambda () #f))
=> (lambda (cp)
(set-checked-pair-log! cp new)))
(else
(hash-set! checked-pair-table p
(make-checked-pair (car p) (cdr p) new)))))
(define checked-pair-lazy-wrap-info
(make-lazy-wrap-info cons
(list checked-raw-car checked-raw-cdr)
(list checked-raw-set-car! checked-raw-set-cdr!)
checked-pair-get-log
checked-pair-set-log!))
(define checked-pair-descriptor
(call-with-values
(lambda ()
(make-struct-type 'dummy-checked-pair #f 0 0 #f
(list
(cons prop:lazy-wrap checked-pair-lazy-wrap-info))))
(lambda (desc . _)
desc)))
(define (make-pair-signature car-sig cdr-sig)
(make-lazy-wrap-signature 'pair checked-pair-descriptor pair? (list car-sig cdr-sig) #'pair))
(define (checked-car p)
(car p)
(check-lazy-wraps! checked-pair-descriptor p)
(checked-raw-car p))
(define (checked-cdr p)
(cdr p)
(check-lazy-wraps! checked-pair-descriptor p)
(checked-raw-cdr p))
; like apply-signature, but can track more precise blame into the signature itself ; like apply-signature, but can track more precise blame into the signature itself
(define-syntax apply-signature/blame (define-syntax apply-signature/blame
(lambda (stx) (lambda (stx)

11
collects/lang/private/teach.rkt
View File

@ -870,7 +870,7 @@
'#,field-name)]) '#,field-name)])
(lambda (r) (lambda (r)
(raw r) ; error checking (raw r) ; error checking
(check-struct-wraps! r) (check-lazy-wraps! type-descriptor r)
(raw r))))) (raw r)))))
getter-names getter-names
fields) fields)
@ -895,10 +895,11 @@
(combined (at name_ (predicate raw-predicate)) (combined (at name_ (predicate raw-predicate))
(at field_ (signature:property getter-name field_/no-loc)) ...))) (at field_ (signature:property getter-name field_/no-loc)) ...)))
#`(define (#,parametric-signature-name field_ ...) #`(define (#,parametric-signature-name field_ ...)
(make-struct-wrap-signature 'name_ (make-lazy-wrap-signature 'name_
type-descriptor type-descriptor
(list field_/no-loc ...) raw-predicate
#'name_))) (list field_/no-loc ...)
#'name_)))
(values #,signature-name #,parametric-signature-name proc-name ...))) (values #,signature-name #,parametric-signature-name proc-name ...)))
'stepper-define-struct-hint 'stepper-define-struct-hint

10
collects/tests/deinprogramm/signature.rkt
View File

@ -377,8 +377,16 @@
(check-equal? (kons 1 '()) (kons 1 '())) (check-equal? (kons 1 '()) (kons 1 '()))
(check-equal? (kons 1 '()) (raw-kons 1 '())) (check-equal? (kons 1 '()) (raw-kons 1 '()))
(check-equal? (raw-kons 1 '()) (kons 1 '()))) (check-equal? (raw-kons 1 '()) (kons 1 '())))
(test-case
"pair-wrap"
(define sig (make-pair-signature integer boolean))
(let ((obj (apply-signature sig (cons 1 #t))))
(check-equal? (checked-car obj) 1)
(check-equal? (checked-cdr obj) #t))
(let ((obj (apply-signature sig (cons 1 2))))
(check-equal? (say-no (checked-car obj)) 'no))
)
)) ))