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

Check parametric struct/record signatures eagerly.

Browse Source
This commit is contained in:
Mike Sperber 2010-10-08 17:01:47 +02:00
parent 5dad68b384
commit 219c91d8e7
4 changed files with 249 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

42
collects/deinprogramm/signature/signature-unit.rkt
View File

@ -413,16 +413,18 @@
(mixed-signature field-signatures-list)
#:transparent)
(define (make-lazy-wrap-signature name type-descriptor predicate field-signatures syntax)
(really-make-lazy-wrap-signature name type-descriptor predicate #f (list field-signatures) syntax))
(define (make-lazy-wrap-signature name eager-checking? type-descriptor predicate field-signatures syntax)
(really-make-lazy-wrap-signature name eager-checking?
type-descriptor predicate #f (list field-signatures) syntax))
; The lists of signatures in `field-signatures-list' form an implicit mixed signature.
(define (really-make-lazy-wrap-signature name type-descriptor predicate
(define (really-make-lazy-wrap-signature name eager-checking? type-descriptor predicate
mixed-signature field-signatures-list
syntax)
(let ((lazy-wrap-info (lazy-wrap-ref type-descriptor))
(not-checked (make-lazy-log-not-checked mixed-signature field-signatures-list))
(lazy-wrap-signature-info (make-lazy-wrap-signature-info type-descriptor predicate field-signatures-list)))
(lazy-wrap-signature-info
(make-lazy-wrap-signature-info eager-checking? type-descriptor predicate field-signatures-list)))
(let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))
(wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info))
@ -453,6 +455,9 @@
(wrap-set! thing
(make-lazy-wrap-log (cons not-checked (lazy-wrap-log-not-checked log))
(lazy-wrap-log-checked log)))))))
(when eager-checking?
(check-lazy-wraps! type-descriptor thing))
thing)
(delay syntax)
@ -479,7 +484,7 @@
(lazy-wrap-signature-info-field-signatures-list other-info)))
(lazy-wrap-signature-info-field-signatures-list this-info))))))))
(define-struct lazy-wrap-signature-info (descriptor predicate field-signatures-list) #:transparent)
(define-struct lazy-wrap-signature-info (eager-checking? descriptor predicate field-signatures-list) #:transparent)
(define (check-lazy-wraps! descriptor thing)
(let ((lazy-wrap-info (lazy-wrap-ref descriptor)))
@ -539,15 +544,19 @@
(define (push-down-lazy-wrap-sigs)
(hash-map lazy-wrap-sigs
(lambda (type-desc signatures)
(really-make-lazy-wrap-signature
(signature-name (car signatures)) type-desc
(lazy-wrap-signature-info-predicate (real-signature-info (car signatures)))
mixed-signature
(apply append
(map (lambda (sig)
(lazy-wrap-signature-info-field-signatures-list (real-signature-info sig)))
signatures))
(signature-syntax (car signatures))))))
(let* ((sig (car signatures))
(info (real-signature-info (car signatures))))
(really-make-lazy-wrap-signature
(signature-name sig)
(lazy-wrap-signature-info-eager-checking? info)
type-desc
(lazy-wrap-signature-info-predicate info)
mixed-signature
(apply append
(map (lambda (sig)
(lazy-wrap-signature-info-field-signatures-list (real-signature-info sig)))
signatures))
(signature-syntax sig))))))
(let loop ((sigs sigs)
(vanilla-sigs '()))
@ -636,8 +645,9 @@
(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 (make-pair-signature eager-checking? car-sig cdr-sig)
(make-lazy-wrap-signature 'pair eager-checking?
checked-pair-descriptor pair? (list car-sig cdr-sig) #'pair))
(define (checked-car p)
(car p)

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

@ -865,13 +865,11 @@
#,@(map-with-index (lambda (i name field-name)
#`(define #,name
(let ([raw (make-struct-field-accessor
(let ([raw (make-struct-field-accessor
raw-generic-access
#,i
'#,field-name)])
(lambda (r)
(raw r) ; error checking
(check-lazy-wraps! type-descriptor r)
(raw r)))))
getter-names
fields)
@ -896,7 +894,7 @@
(combined (at name_ (predicate raw-predicate))
(at field_ (signature:property getter-name field_/no-loc)) ...)))
#`(define (#,parametric-signature-name field_ ...)
(make-lazy-wrap-signature 'name_
(make-lazy-wrap-signature 'name_ #t
type-descriptor
raw-predicate
(list field_/no-loc ...)
@ -2912,7 +2910,7 @@
(define Unspecific (signature (predicate (lambda (_) #t))))
(define (cons-of car-sig cdr-sig)
(make-pair-signature car-sig cdr-sig))
(make-pair-signature #t car-sig cdr-sig))
; QuickCheck

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

@ -258,6 +258,38 @@
"record-wrap"
(define-record-procedures-parametric pare pare-of kons pare? (kar kdr))
(define ctr (pare-of integer boolean))
(let ((obj (apply-signature ctr (kons 1 #t))))
(check-equal? (kar obj) 1)
(check-equal? (kdr obj) #t))
(check-equal? (say-no (apply-signature ctr (kons 1 2))) 'no)
)
(test-case
"record-wrap/lazy"
(define-struct pare (kar kdr extra)
#:mutable
#:property prop:lazy-wrap
(make-lazy-wrap-info
(lambda (kar kdr) (kons kar kdr))
(list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x)))
(list (lambda (x v) (set-pare-kar! x v))
(lambda (x v) (set-pare-kdr! x v)))
(lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v))))
(define (kons kar kdr)
(make-pare kar kdr #f))
(define (kar p)
(check-lazy-wraps! struct:pare p)
(pare-kar p))
(define (kdr p)
(check-lazy-wraps! struct:pare p)
(pare-kdr p))
(define (pare-of kar-sig kdr-sig)
(make-lazy-wrap-signature 'pare #f
struct:pare
pare?
(list kar-sig kdr-sig)
#f))
(define ctr (pare-of integer boolean))
(let ((obj (apply-signature ctr (kons 1 #t))))
(check-equal? (kar obj) 1)
(check-equal? (kdr obj) #t))
@ -270,11 +302,53 @@
(let ((count 0))
(define counting-integer
(make-predicate-signature 'counting-integer
(lambda (obj)
(set! count (+ 1 count))
(integer? obj))
'integer-marker))
(lambda (obj)
(set! count (+ 1 count))
(integer? obj))
'integer-marker))
(define-record-procedures-parametric pare pare-of kons pare? (kar kdr))
(define ctr (signature (pare-of counting-integer boolean)))
(let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t)))))
(check-equal? count 1)
(check-equal? (kar obj) 1)
(check-equal? count 1)
(check-equal? (kdr obj) #t)
(check-equal? count 1))))
(test-case
"record-wrap-2/lazy"
(let ((count 0))
(define counting-integer
(make-predicate-signature 'counting-integer
(lambda (obj)
(set! count (+ 1 count))
(integer? obj))
'integer-marker))
(define-struct pare (kar kdr extra)
#:mutable
#:property prop:lazy-wrap
(make-lazy-wrap-info
(lambda (kar kdr) (kons kar kdr))
(list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x)))
(list (lambda (x v) (set-pare-kar! x v))
(lambda (x v) (set-pare-kdr! x v)))
(lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v))))
(define (kons kar kdr)
(make-pare kar kdr #f))
(define (kar p)
(check-lazy-wraps! struct:pare p)
(pare-kar p))
(define (kdr p)
(check-lazy-wraps! struct:pare p)
(pare-kdr p))
(define (pare-of kar-sig kdr-sig)
(make-lazy-wrap-signature 'pare #f
struct:pare
pare?
(list kar-sig kdr-sig)
#f))
(define ctr (signature (pare-of counting-integer boolean)))
(let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t)))))
(check-equal? count 0)
@ -283,9 +357,8 @@
(check-equal? (kdr obj) #t)
(check-equal? count 1))))
(test-case
"record-wrap-2"
"record-wrap-3"
(let ((count 0))
(define counting-integer
(make-predicate-signature 'counting-integer
@ -293,7 +366,56 @@
(set! count (+ 1 count))
(integer? obj))
'integer-marker))
(define-record-procedures-parametric pare pare-of kons pare? (kar kdr))
(define ctr (signature (pare-of counting-integer boolean)))
(let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t)))))
(check-equal? count 1)
(check-equal? (kar obj) 1)
(check-equal? count 1)
(check-equal? (kdr obj) #t)
(check-equal? count 1)
;; after checking, the system should remember that it did so
(let ((obj-2 (apply-signature ctr obj)))
(check-equal? count 1)
(check-equal? (kar obj) 1)
(check-equal? count 1)
(check-equal? (kdr obj) #t)
(check-equal? count 1)))))
(test-case
"record-wrap-3/lazy"
(let ((count 0))
(define counting-integer
(make-predicate-signature 'counting-integer
(lambda (obj)
(set! count (+ 1 count))
(integer? obj))
'integer-marker))
(define-struct pare (kar kdr extra)
#:mutable
#:property prop:lazy-wrap
(make-lazy-wrap-info
(lambda (kar kdr) (kons kar kdr))
(list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x)))
(list (lambda (x v) (set-pare-kar! x v))
(lambda (x v) (set-pare-kdr! x v)))
(lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v))))
(define (kons kar kdr)
(make-pare kar kdr #f))
(define (kar p)
(check-lazy-wraps! struct:pare p)
(pare-kar p))
(define (kdr p)
(check-lazy-wraps! struct:pare p)
(pare-kdr p))
(define (pare-of kar-sig kdr-sig)
(make-lazy-wrap-signature 'pare #f
struct:pare
pare?
(list kar-sig kdr-sig)
#f))
(define ctr (signature (pare-of counting-integer boolean)))
(let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t)))))
(check-equal? count 0)
@ -320,6 +442,70 @@
'integer-marker))
(define-record-procedures-parametric pare pare-of raw-kons pare? (kar kdr))
(define empty-list (signature (predicate null?)))
(define my-list-of
(lambda (x)
(signature (mixed empty-list
(pare-of x (my-list-of x))))))
(define/signature kons (signature (%a (my-list-of %a) -> (pare-of %a (my-list-of %a))))
raw-kons)
(define/signature build-list (signature (integer -> (my-list-of counting-integer)))
(lambda (n)
(if (= n 0)
'()
(kons n (build-list (- n 1))))))
(define/signature list-length (signature ((my-list-of counting-integer) -> integer))
(lambda (lis)
(cond
((null? lis) 0)
((pare? lis)
(+ 1 (list-length (kdr lis)))))))
;; one wrap each for (my-list-of %a), one for (my-list-of counting-integer)
(let ((l1 (build-list 10)))
(check-equal? count 10)
(let ((len1 (list-length l1)))
(check-equal? count 10)))))
(test-case
"double-wrap/lazy"
(let ((count 0))
(define counting-integer
(make-predicate-signature 'counting-integer
(lambda (obj)
(set! count (+ 1 count))
(integer? obj))
'integer-marker))
(define-struct pare (kar kdr extra)
#:mutable
#:property prop:lazy-wrap
(make-lazy-wrap-info
(lambda (kar kdr) (raw-kons kar kdr))
(list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x)))
(list (lambda (x v) (set-pare-kar! x v))
(lambda (x v) (set-pare-kdr! x v)))
(lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v))))
(define (raw-kons kar kdr)
(make-pare kar kdr #f))
(define (kar p)
(check-lazy-wraps! struct:pare p)
(pare-kar p))
(define (kdr p)
(check-lazy-wraps! struct:pare p)
(pare-kdr p))
(define (pare-of kar-sig kdr-sig)
(make-lazy-wrap-signature 'pare #f
struct:pare
pare?
(list kar-sig kdr-sig)
#f))
(define empty-list (signature (predicate null?)))
(define my-list-of
@ -351,7 +537,32 @@
(test-case
"mixed wrap"
(define-record-procedures-parametric pare pare-of raw-kons pare? (kar kdr))
(define-struct pare (kar kdr extra)
#:mutable
#:property prop:lazy-wrap
(make-lazy-wrap-info
(lambda (kar kdr) (raw-kons kar kdr))
(list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x)))
(list (lambda (x v) (set-pare-kar! x v))
(lambda (x v) (set-pare-kdr! x v)))
(lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v))))
(define (raw-kons kar kdr)
(make-pare kar kdr #f))
(define (kar p)
(check-lazy-wraps! struct:pare p)
(pare-kar p))
(define (kdr p)
(check-lazy-wraps! struct:pare p)
(pare-kdr p))
(define (pare-of kar-sig kdr-sig)
(make-lazy-wrap-signature 'pare #f
struct:pare
pare?
(list kar-sig kdr-sig)
#f))
(define sig1 (signature (pare-of integer boolean)))
(define sig2 (signature (pare-of boolean integer)))
(define sig (signature (mixed sig1 sig2)))
@ -381,7 +592,7 @@
(test-case
"pair-wrap"
(define sig (make-pair-signature integer boolean))
(define sig (make-pair-signature #f integer boolean))
(let ((obj (apply-signature sig (cons 1 #t))))
(check-equal? (checked-car obj) 1)
(check-equal? (checked-cdr obj) #t))