Lazy contract checking for DMdA's `define-record-procedures-parametric'.
svn: r18806
This commit is contained in:
parent
a12018874e
commit
9d20fd713d
|
@ -83,7 +83,8 @@
|
|||
#'(contract-update-syntax contract/contract #'?loc)))
|
||||
(?id
|
||||
(identifier? #'?id)
|
||||
(with-syntax ((?stx (phase-lift stx)))
|
||||
(with-syntax ((?stx (phase-lift stx))
|
||||
(?name name))
|
||||
(let ((name (symbol->string (syntax->datum #'?id))))
|
||||
(if (char=? #\% (string-ref name 0))
|
||||
#'(make-type-variable-contract '?id ?stx)
|
||||
|
@ -91,13 +92,19 @@
|
|||
((?raise
|
||||
(syntax/loc #'?stx
|
||||
(error 'contracts "expected a contract, found ~e" ?id))))
|
||||
#'(make-delayed-contract '?name
|
||||
(delay
|
||||
(begin
|
||||
(when (not (contract? ?id))
|
||||
?raise)
|
||||
(contract-update-syntax ?id ?stx)))
|
||||
#'?stx))))))
|
||||
(with-syntax
|
||||
((?ctr
|
||||
#'(make-delayed-contract '?name
|
||||
(delay
|
||||
(begin
|
||||
(when (not (contract? ?id))
|
||||
?raise)
|
||||
?id)))))
|
||||
;; for local variables (parameters, most probably),
|
||||
;; we want the value to determine the blame location
|
||||
(if (eq? (identifier-binding #'?id) 'lexical)
|
||||
#'?ctr
|
||||
#'(contract-update-syntax ?ctr #'?stx))))))))
|
||||
((combined ?contract ...)
|
||||
(with-syntax ((?stx (phase-lift stx))
|
||||
(?name name)
|
||||
|
@ -118,14 +125,16 @@
|
|||
((?contract-abstr ?contract ...)
|
||||
(identifier? #'?contract-abstr)
|
||||
(with-syntax ((?stx (phase-lift stx))
|
||||
(?name name)
|
||||
((?contract-expr ...) (map (lambda (ctr)
|
||||
(parse-contract #f ctr))
|
||||
(syntax->list #'(?contract ...)))))
|
||||
(with-syntax
|
||||
((?call (syntax/loc stx (?contract-abstr ?contract-expr ...))))
|
||||
#'(make-delayed-contract '?name
|
||||
(delay ?call)
|
||||
?stx))))
|
||||
#'(make-call-contract '?name
|
||||
(delay ?call)
|
||||
(delay ?contract-abstr) (delay (list ?contract-expr ...))
|
||||
?stx))))
|
||||
(else
|
||||
(raise-syntax-error 'contract
|
||||
"ungültiger Vertrag" stx))))
|
||||
|
@ -175,7 +184,7 @@
|
|||
(syntax-case stx ()
|
||||
((_ ?name ?cnt ?expr)
|
||||
(with-syntax ((?enforced
|
||||
(stepper-syntax-property #'(attach-name '?name (apply-contract/blame (contract ?cnt) ?expr))
|
||||
(stepper-syntax-property #'(attach-name '?name (apply-contract/blame ?cnt ?expr))
|
||||
'stepper-skipto/discard
|
||||
;; apply-contract/blame takes care of itself
|
||||
;; remember there's an implicit #%app
|
||||
|
@ -205,7 +214,7 @@
|
|||
((?id ?cnt)
|
||||
(identifier? #'?id)
|
||||
(cons #'?id
|
||||
#'(attach-name '?id (apply-contract/blame (contract ?cnt) ?id))))))
|
||||
#'(attach-name '?id (apply-contract/blame ?cnt ?id))))))
|
||||
(syntax->list #'(?bind ...)))))
|
||||
(with-syntax (((?id ...) (map car ids+enforced))
|
||||
((?enforced ...) (map cdr ids+enforced)))
|
||||
|
|
|
@ -3,9 +3,11 @@
|
|||
(provide contract?
|
||||
contract-name contract-syntax
|
||||
contract-arbitrary set-contract-arbitrary!
|
||||
contract-violation-proc
|
||||
call-with-contract-violation-proc
|
||||
contract-info-promise
|
||||
contract-violation
|
||||
contract-violation-proc call-with-contract-violation-proc
|
||||
make-delayed-contract
|
||||
make-call-contract
|
||||
make-property-contract
|
||||
make-predicate-contract
|
||||
make-type-variable-contract
|
||||
|
@ -14,21 +16,56 @@
|
|||
make-combined-contract
|
||||
make-case-contract
|
||||
make-procedure-contract
|
||||
contract-update-syntax
|
||||
apply-contract apply-contract/blame)
|
||||
contract-update-syntax contract-update-info-promise
|
||||
apply-contract apply-contract/blame
|
||||
procedure-contract-info?
|
||||
procedure-contract-info-arg-contracts procedure-contract-info-return-contract
|
||||
make-lazy-wrap-info lazy-wrap-info-constructor lazy-wrap-info-raw-accessors
|
||||
prop:lazy-wrap lazy-wrap-ref
|
||||
make-struct-wrap-contract
|
||||
check-struct-wraps!
|
||||
contract=? contract<=?)
|
||||
|
||||
(require scheme/promise
|
||||
mzlib/struct
|
||||
(for-syntax scheme/base)
|
||||
(for-syntax stepper/private/shared))
|
||||
|
||||
(require deinprogramm/quickcheck/quickcheck)
|
||||
|
||||
(define (contract=? c1 c2)
|
||||
(or (eq? c1 c2)
|
||||
(eq? (contract-enforcer c1) (contract-enforcer c2))
|
||||
(and (contract-=?-proc c1)
|
||||
((contract-=?-proc c1)
|
||||
(force (contract-info-promise c1))
|
||||
(force (contract-info-promise c2))))))
|
||||
|
||||
; name may be #f
|
||||
; enforcer: contract val -> val
|
||||
;
|
||||
; syntax: syntax data from where the contract was defined
|
||||
|
||||
(define-struct contract (name enforcer syntax (arbitrary-promise #:mutable)))
|
||||
(define-struct contract (name enforcer syntax-promise (arbitrary-promise #:mutable) info-promise <=?-proc =?-proc)
|
||||
#:constructor-name really-make-contract
|
||||
#:transparent ; #### for debugging, remove
|
||||
#:property prop:equal+hash
|
||||
(list (lambda (c1 c2 equal?) (contract=? c1 c2)) ; #### use equal?
|
||||
void void)) ; hash procs
|
||||
|
||||
(define (make-contract name enforcer syntax-promise
|
||||
#:arbitrary-promise (arbitrary-promise #f)
|
||||
#:info-promise (info-promise (delay #f))
|
||||
#:<=?-proc (<=?-proc
|
||||
(lambda (this-info other-info)
|
||||
#f))
|
||||
#:=?-proc (=?-proc
|
||||
(lambda (this-info other-info)
|
||||
#f)))
|
||||
(really-make-contract name enforcer syntax-promise arbitrary-promise info-promise <=?-proc =?-proc))
|
||||
|
||||
(define (contract-syntax ctr)
|
||||
(force (contract-syntax-promise ctr)))
|
||||
|
||||
(define (contract-arbitrary ctr)
|
||||
(force (contract-arbitrary-promise ctr)))
|
||||
|
@ -37,7 +74,11 @@
|
|||
(set-contract-arbitrary-promise! ctr (delay arb)))
|
||||
|
||||
(define (contract-update-syntax ctr stx)
|
||||
(struct-copy contract ctr (syntax stx)))
|
||||
(struct-copy contract ctr (syntax-promise (delay stx))))
|
||||
|
||||
;; it's a promise because of ordering constraints in the structs
|
||||
(define (contract-update-info-promise ctr inf)
|
||||
(struct-copy contract ctr (info-promise inf)))
|
||||
|
||||
; message may be #f
|
||||
(define contract-violation-proc (make-parameter (lambda (obj contract message blame)
|
||||
|
@ -52,13 +93,45 @@
|
|||
(parameterize ((contract-violation-proc proc))
|
||||
(thunk)))
|
||||
|
||||
(define (make-delayed-contract name promise syntax)
|
||||
(define (make-delayed-contract name promise)
|
||||
(make-contract name
|
||||
(lambda (self obj)
|
||||
((contract-enforcer (force promise)) self obj))
|
||||
syntax
|
||||
(delay (contract-syntax (force promise)))
|
||||
#:arbitrary-promise
|
||||
(delay
|
||||
(force (contract-arbitrary-promise (force promise))))))
|
||||
(force (contract-arbitrary-promise (force promise))))
|
||||
#:info-promise
|
||||
(delay
|
||||
(force (contract-info-promise (force promise))))
|
||||
#:<=?-proc
|
||||
(lambda (this-info other-info)
|
||||
((contract-<=?-proc (force promise)) this-info other-info))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
((contract-=?-proc (force promise)) this-info other-info))))
|
||||
|
||||
; specialized version of the above, supports comparison
|
||||
; the promise must produce the result of (proc . args), but its passed separately
|
||||
; to give us the right location on backtrace
|
||||
(define (make-call-contract name promise proc-promise args-promise syntax)
|
||||
(make-contract name
|
||||
(lambda (self obj)
|
||||
((contract-enforcer (force promise)) self obj))
|
||||
(delay syntax)
|
||||
#:arbitrary-promise
|
||||
(delay
|
||||
(force (contract-arbitrary-promise (force promise))))
|
||||
#:info-promise
|
||||
(delay
|
||||
(make-call-info (force proc-promise) (force args-promise)))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (call-info? other-info)
|
||||
(eqv? (force proc-promise) (call-info-proc other-info))
|
||||
(equal? (force args-promise) (call-info-args other-info))))))
|
||||
|
||||
(define-struct call-info (proc args) #:transparent)
|
||||
|
||||
(define (make-property-contract name access contract syntax)
|
||||
(let ((enforce (contract-enforcer contract)))
|
||||
|
@ -66,8 +139,7 @@
|
|||
(lambda (self obj)
|
||||
(enforce self (access obj)) ; #### problematic: enforcement doesn't stick
|
||||
obj)
|
||||
syntax
|
||||
#f)))
|
||||
syntax)))
|
||||
|
||||
(define (make-predicate-contract name predicate-promise syntax)
|
||||
(make-contract
|
||||
|
@ -78,11 +150,29 @@
|
|||
(begin
|
||||
(contract-violation obj self #f #f)
|
||||
obj)))
|
||||
syntax
|
||||
#f))
|
||||
(delay syntax)
|
||||
#:info-promise
|
||||
(delay (make-predicate-info (force predicate-promise)))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (predicate-info? other-info)
|
||||
(eq? (force predicate-promise)
|
||||
(predicate-info-predicate other-info))))))
|
||||
|
||||
(define-struct predicate-info (predicate) #:transparent)
|
||||
|
||||
(define (make-type-variable-contract name syntax)
|
||||
(make-predicate-contract name (lambda (obj) #t) syntax))
|
||||
(make-contract
|
||||
name
|
||||
(lambda (self obj) obj)
|
||||
(delay syntax)
|
||||
#:info-promise
|
||||
(delay (make-type-variable-info))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(type-variable-info? other-info))))
|
||||
|
||||
(define-struct type-variable-info ())
|
||||
|
||||
; maps lists to pairs of contract, enforced value
|
||||
(define lists-table (make-weak-hasheq))
|
||||
|
@ -116,8 +206,17 @@
|
|||
(else
|
||||
(go-on)))))
|
||||
syntax
|
||||
#:arbitrary-promise
|
||||
(delay
|
||||
(lift->arbitrary arbitrary-list arg-contract))))
|
||||
(lift->arbitrary arbitrary-list arg-contract))
|
||||
#:info-promise
|
||||
(delay (make-list-info arg-contract))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (list-info? other-info)
|
||||
(contract=? arg-contract (list-info-arg-contract other-info))))))
|
||||
|
||||
(define-struct list-info (arg-contract) #:transparent)
|
||||
|
||||
(define (lift->arbitrary proc . contracts)
|
||||
(let ((arbitraries (map force (map contract-arbitrary-promise contracts))))
|
||||
|
@ -147,7 +246,8 @@
|
|||
obj
|
||||
values
|
||||
(lambda () (loop (cdr alternative-contracts))))))))
|
||||
syntax
|
||||
(delay syntax)
|
||||
#:arbitrary-promise
|
||||
(delay
|
||||
(let ((arbitraries (map force (map contract-arbitrary-promise alternative-contracts))))
|
||||
(if (andmap values arbitraries)
|
||||
|
@ -191,8 +291,7 @@
|
|||
(lambda () obj)
|
||||
(loop (cdr contracts)
|
||||
(apply-contract (car contracts) obj))))))))))
|
||||
syntax
|
||||
#f))
|
||||
(delay syntax)))
|
||||
|
||||
(define (make-case-contract name cases =? syntax)
|
||||
(make-contract
|
||||
|
@ -207,13 +306,16 @@
|
|||
obj)
|
||||
(else
|
||||
(loop (cdr cases))))))
|
||||
syntax
|
||||
(delay syntax)
|
||||
#:arbitrary-promise
|
||||
(delay (apply arbitrary-one-of =? cases))))
|
||||
|
||||
(define-struct procedure-to-blame (proc syntax))
|
||||
|
||||
(define contract-key (gensym 'contract-key))
|
||||
|
||||
(define-struct procedure-contract-info (arg-contracts return-contract) #:transparent)
|
||||
|
||||
(define (make-procedure-contract name arg-contracts return-contract syntax)
|
||||
(let ((arg-count (length arg-contracts)))
|
||||
(make-contract
|
||||
|
@ -265,9 +367,13 @@
|
|||
(lambda ()
|
||||
(apply-contract return-contract retval)))))))))))
|
||||
(procedure-arity proc)))))))
|
||||
syntax
|
||||
(delay syntax)
|
||||
#:arbitrary-promise
|
||||
(delay
|
||||
(apply lift->arbitrary arbitrary-procedure return-contract arg-contracts)))))
|
||||
(apply lift->arbitrary arbitrary-procedure return-contract arg-contracts))
|
||||
#:info-promise
|
||||
(delay
|
||||
(make-procedure-contract-info arg-contracts return-contract)))))
|
||||
|
||||
(define (attach-name name thing)
|
||||
(if (and (procedure? thing)
|
||||
|
@ -275,6 +381,96 @@
|
|||
(procedure-rename thing name)
|
||||
thing))
|
||||
|
||||
; Lazy contract checking for structs
|
||||
|
||||
;; This is attached prop:lazy-wrap property of struct types subject to
|
||||
;; lazy checking.
|
||||
(define-struct lazy-wrap-info
|
||||
(constructor
|
||||
raw-accessors raw-mutators
|
||||
;; procedures for referencing or setting an additional field within the struct
|
||||
;; that field contains a list of lists of unchecked field contracts
|
||||
ref-proc set!-proc))
|
||||
|
||||
; value should be a lazy-wrap-info
|
||||
(define-values (prop:lazy-wrap lazy-wrap lazy-wrap-ref)
|
||||
(make-struct-type-property 'lazy-wrap))
|
||||
|
||||
(define (make-struct-wrap-contract name type-descriptor field-contracts syntax)
|
||||
(let ((lazy-wrap-info (lazy-wrap-ref type-descriptor))
|
||||
(struct-wrap-info (make-struct-wrap-info type-descriptor field-contracts))
|
||||
(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))
|
||||
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))
|
||||
(wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info))
|
||||
(wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info)))
|
||||
(make-contract
|
||||
name
|
||||
(lambda (self thing)
|
||||
|
||||
(cond
|
||||
((not (predicate thing))
|
||||
(contract-violation thing self #f #f)
|
||||
thing)
|
||||
((ormap (lambda (wrap-field-contracts)
|
||||
(andmap contract<=?
|
||||
wrap-field-contracts
|
||||
field-contracts))
|
||||
(wrap-ref thing))
|
||||
thing)
|
||||
(else
|
||||
(wrap-set! thing
|
||||
(cons field-contracts (wrap-ref thing)))
|
||||
thing)))
|
||||
(delay syntax)
|
||||
#:info-promise
|
||||
(delay struct-wrap-info)
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (struct-wrap-info? other-info)
|
||||
(struct-wrap-info-field-contracts other-info)
|
||||
(eq? type-descriptor (struct-wrap-info-descriptor other-info))
|
||||
(andmap contract=?
|
||||
field-contracts
|
||||
(struct-wrap-info-field-contracts other-info))))
|
||||
#:<=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (struct-wrap-info? other-info)
|
||||
(struct-wrap-info-field-contracts other-info)
|
||||
(eq? type-descriptor (struct-wrap-info-descriptor other-info))
|
||||
(andmap contract<=?
|
||||
field-contracts
|
||||
(struct-wrap-info-field-contracts other-info))))))))
|
||||
|
||||
(define-struct struct-wrap-info (descriptor field-contracts))
|
||||
|
||||
(define (check-struct-wraps! thing)
|
||||
(let-values (((descriptor skipped?) (struct-info thing)))
|
||||
(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)))
|
||||
|
||||
(when (pair? (wrap-ref thing)) ; fast path
|
||||
(let loop ((field-vals (map (lambda (raw-accessor)
|
||||
(raw-accessor thing))
|
||||
raw-accessors))
|
||||
(field-contracts-list (wrap-ref thing)))
|
||||
(if (null? field-contracts-list)
|
||||
(begin
|
||||
(for-each (lambda (raw-mutator field-val)
|
||||
(raw-mutator thing field-val))
|
||||
raw-mutators field-vals)
|
||||
(wrap-set! thing '()))
|
||||
(loop (map apply-contract (car field-contracts-list) field-vals)
|
||||
(cdr field-contracts-list)))))))))
|
||||
|
||||
; like apply-contract, but can track more precise blame into the contract itself
|
||||
(define-syntax apply-contract/blame
|
||||
(lambda (stx)
|
||||
|
@ -306,3 +502,14 @@
|
|||
|
||||
(define (apply-contract contract val)
|
||||
((contract-enforcer contract) contract val))
|
||||
|
||||
; "do the values that fulfill c1 also fulfill c2?"
|
||||
(define (contract<=? c1 c2)
|
||||
(or (contract=? c1 c2)
|
||||
(let ((i1 (force (contract-info-promise c1)))
|
||||
(i2 (force (contract-info-promise c2))))
|
||||
(or (type-variable-info? i2) ; kludge, maybe dispatch should be on second arg
|
||||
(and i1 i2
|
||||
((contract-<=?-proc c1) i1 i2))))))
|
||||
|
||||
|
||||
|
|
|
@ -86,15 +86,15 @@
|
|||
((define-values (?id ...) ?e1)
|
||||
(with-syntax (((?enforced ...)
|
||||
(map (lambda (id)
|
||||
(with-syntax ((?id id))
|
||||
(cond
|
||||
((bound-identifier-mapping-get contract-table #'?id (lambda () #f))
|
||||
=> (lambda (cnt)
|
||||
(bound-identifier-mapping-put! contract-table #'?id #f) ; check for orphaned contracts
|
||||
(with-syntax ((?cnt cnt))
|
||||
#'(?id ?cnt))))
|
||||
(else
|
||||
#'?id))))
|
||||
(cond
|
||||
((bound-identifier-mapping-get contract-table id (lambda () #f))
|
||||
=> (lambda (cnt)
|
||||
(bound-identifier-mapping-put! contract-table id #f) ; check for orphaned contracts
|
||||
(with-syntax ((?id id)
|
||||
(?cnt cnt))
|
||||
#'(?id (contract ?cnt)))))
|
||||
(else
|
||||
id)))
|
||||
(syntax->list #'(?id ...))))
|
||||
(?rest (loop (cdr exprs))))
|
||||
(with-syntax ((?defn
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
;; I HATE DEFINE-STRUCT!
|
||||
; I HATE DEFINE-STRUCT!
|
||||
(define-struct/properties :empty-list ()
|
||||
((prop:custom-write
|
||||
(lambda (r port write?)
|
||||
|
@ -72,21 +72,20 @@
|
|||
(else
|
||||
(cons (recur (car v))
|
||||
(list-recur (cdr v))))))))
|
||||
((deinprogramm-struct? v)
|
||||
((struct? v)
|
||||
(or (hash-ref hash v #f)
|
||||
(let*-values (((ty skipped?) (struct-info v))
|
||||
((name-symbol
|
||||
init-field-k auto-field-k accessor-proc mutator-proc immutable-k-list
|
||||
super-struct-type skipped?)
|
||||
(struct-type-info ty)))
|
||||
(let* ((indices (iota (+ init-field-k auto-field-k)))
|
||||
(val (apply (struct-type-make-constructor ty) indices)))
|
||||
(hash-set! hash v val)
|
||||
(for-each (lambda (index)
|
||||
(mutator-proc val index
|
||||
(recur (accessor-proc v index))))
|
||||
indices)
|
||||
val))))
|
||||
(let-values (((ty skipped?) (struct-info v)))
|
||||
(cond
|
||||
((and ty (lazy-wrap-ref ty))
|
||||
=> (lambda (lazy-wrap-info)
|
||||
(let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
|
||||
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info)))
|
||||
(let ((val (apply constructor (map (lambda (raw-accessor)
|
||||
(recur (raw-accessor v)))
|
||||
raw-accessors))))
|
||||
(hash-set! hash v val)
|
||||
val))))
|
||||
(else v)))))
|
||||
(else
|
||||
v)))))
|
||||
|
||||
|
|
|
@ -2,10 +2,9 @@
|
|||
(provide convert-explicit)
|
||||
|
||||
(require mzlib/pretty
|
||||
mzlib/struct
|
||||
(only-in srfi/1 iota))
|
||||
mzlib/struct)
|
||||
|
||||
(require deinprogramm/deinprogramm-struct)
|
||||
(require deinprogramm/contract/contract)
|
||||
|
||||
(require scheme/include)
|
||||
(include "convert-explicit.scm")
|
||||
|
|
|
@ -27,13 +27,15 @@
|
|||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ ?type-name
|
||||
?mutable?
|
||||
?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
(?field-spec ...))
|
||||
|
||||
(with-syntax
|
||||
(((accessor ...)
|
||||
((number-of-fields (length (syntax->list (syntax (?field-spec ...)))))
|
||||
((accessor ...)
|
||||
(map (lambda (field-spec)
|
||||
(syntax-case field-spec ()
|
||||
((accessor mutator) (syntax accessor))
|
||||
|
@ -47,129 +49,151 @@
|
|||
(syntax->list (syntax (?field-spec ...)))
|
||||
(generate-temporaries (syntax (?field-spec ...))))))
|
||||
(with-syntax
|
||||
((number-of-fields (length (syntax->list
|
||||
(syntax (accessor ...)))))
|
||||
(generic-access (syntax generic-access))
|
||||
(generic-mutate (syntax generic-mutate)))
|
||||
(with-syntax
|
||||
(((accessor-proc ...)
|
||||
(map-with-index
|
||||
(lambda (i accessor)
|
||||
(with-syntax ((i i)
|
||||
(tag accessor))
|
||||
(syntax-property (syntax/loc
|
||||
accessor
|
||||
(lambda (s)
|
||||
(when (not (?predicate s))
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(string->immutable-string
|
||||
(format "~a: Argument kein ~a: ~e"
|
||||
'tag '?type-name s))
|
||||
(current-continuation-marks))))
|
||||
(generic-access s i)))
|
||||
'inferred-name
|
||||
(syntax-e accessor))))
|
||||
(syntax->list (syntax (accessor ...)))))
|
||||
((our-accessor ...) (generate-temporaries #'(accessor ...)))
|
||||
((mutator-proc ...)
|
||||
(map-with-index
|
||||
(lambda (i mutator)
|
||||
(with-syntax ((i i)
|
||||
(tag mutator))
|
||||
(syntax-property (syntax/loc
|
||||
mutator
|
||||
(lambda (s v)
|
||||
(when (not (?predicate s))
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(string->immutable-string
|
||||
(format "~a: Argument kein ~a: ~e"
|
||||
'tag '?type-name s))
|
||||
(current-continuation-marks))))
|
||||
(generic-mutate s i v)))
|
||||
'inferred-name
|
||||
(syntax-e mutator))))
|
||||
(syntax->list (syntax (mutator ...)))))
|
||||
(constructor-proc
|
||||
(syntax-property (syntax
|
||||
(lambda (accessor ...)
|
||||
(?constructor accessor ...)))
|
||||
'inferred-name
|
||||
(syntax-e (syntax ?constructor))))
|
||||
(predicate-proc
|
||||
(syntax-property (syntax
|
||||
(lambda (thing)
|
||||
(?predicate thing)))
|
||||
'inferred-name
|
||||
(syntax-e (syntax ?predicate))))
|
||||
(constructor-name (syntax ?constructor)))
|
||||
(with-syntax
|
||||
((defs
|
||||
#'(define-values (?constructor
|
||||
?predicate real-predicate
|
||||
accessor ...
|
||||
our-accessor ...
|
||||
mutator ...)
|
||||
(letrec-values (((type-descriptor
|
||||
?constructor
|
||||
?predicate
|
||||
generic-access
|
||||
generic-mutate)
|
||||
(make-struct-type
|
||||
'?type-name #f number-of-fields 0
|
||||
#f
|
||||
(list
|
||||
(cons prop:print-convert-constructor-name
|
||||
'constructor-name)
|
||||
(cons prop:deinprogramm-struct
|
||||
#t)
|
||||
(cons prop:custom-write
|
||||
(lambda (r port write?)
|
||||
(custom-write-record '?type-name
|
||||
(access-record-fields r generic-access number-of-fields)
|
||||
port write?))))
|
||||
(make-inspector))))
|
||||
(values constructor-proc
|
||||
predicate-proc predicate-proc
|
||||
accessor-proc ...
|
||||
accessor-proc ...
|
||||
mutator-proc ...))))
|
||||
(contract
|
||||
(with-syntax (((?param ...) (generate-temporaries #'(?field-spec ...))))
|
||||
(with-syntax (((component-contract ...)
|
||||
(map (lambda (accessor param)
|
||||
(with-syntax ((?accessor accessor)
|
||||
(?param param))
|
||||
#'(at ?param (property ?accessor ?param))))
|
||||
(syntax->list #'(our-accessor ...))
|
||||
(syntax->list #'(?param ...)))))
|
||||
(with-syntax ((base-contract
|
||||
(stepper-syntax-property
|
||||
#'(define ?type-name (contract (predicate real-predicate)))
|
||||
'stepper-skip-completely
|
||||
#t))
|
||||
(constructor-contract
|
||||
(stepper-syntax-property
|
||||
#'(define (?contract-constructor-name ?param ...)
|
||||
(contract
|
||||
(combined (at ?type-name (predicate real-predicate))
|
||||
component-contract ...)))
|
||||
'stepper-skip-completely
|
||||
#t)))
|
||||
#'(begin
|
||||
;; we use real-predicate to avoid infinite recursion if a contract
|
||||
;; for ?type-name using ?predicate is inadvertently defined
|
||||
base-contract
|
||||
constructor-contract))))))
|
||||
(with-syntax ((defs
|
||||
(stepper-syntax-property
|
||||
(syntax/loc x defs) 'stepper-skip-completely #t)))
|
||||
(((accessor-proc ...)
|
||||
(map-with-index
|
||||
(lambda (i accessor)
|
||||
(with-syntax ((i i)
|
||||
(tag accessor))
|
||||
(syntax-property (syntax/loc
|
||||
accessor
|
||||
(lambda (s)
|
||||
(when (not (raw-predicate s))
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(string->immutable-string
|
||||
(format "~a: Argument kein ~a: ~e"
|
||||
'tag '?type-name s))
|
||||
(current-continuation-marks))))
|
||||
(check-struct-wraps! s)
|
||||
(raw-generic-access s i)))
|
||||
'inferred-name
|
||||
(syntax-e accessor))))
|
||||
(syntax->list #'(accessor ...))))
|
||||
((our-accessor ...) (generate-temporaries #'(accessor ...)))
|
||||
((mutator-proc ...)
|
||||
(map-with-index
|
||||
(lambda (i mutator)
|
||||
(with-syntax ((i i)
|
||||
(tag mutator))
|
||||
(syntax-property (syntax/loc
|
||||
mutator
|
||||
(lambda (s v)
|
||||
(when (not (raw-predicate s))
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(string->immutable-string
|
||||
(format "~a: Argument kein ~a: ~e"
|
||||
'tag '?type-name s))
|
||||
(current-continuation-marks))))
|
||||
(raw-generic-mutate s i v)))
|
||||
'inferred-name
|
||||
(syntax-e mutator))))
|
||||
(syntax->list #'(mutator ...))))
|
||||
(constructor-proc
|
||||
(syntax-property #'(lambda (accessor ...)
|
||||
(raw-constructor accessor ... '()))
|
||||
'inferred-name
|
||||
(syntax-e #'?constructor)))
|
||||
(predicate-proc
|
||||
(syntax-property #'(lambda (thing)
|
||||
(raw-predicate thing))
|
||||
'inferred-name
|
||||
(syntax-e #'?predicate)))
|
||||
((raw-accessor-proc ...)
|
||||
(map-with-index (lambda (i _)
|
||||
#`(lambda (r)
|
||||
(raw-generic-access r #,i)))
|
||||
(syntax->list #'(?field-spec ...))))
|
||||
((raw-mutator-proc ...)
|
||||
(map-with-index (lambda (i _)
|
||||
#`(lambda (r val)
|
||||
(raw-generic-mutate r #,i val)))
|
||||
(syntax->list #'(?field-spec ...))))
|
||||
|
||||
(record-equal? #`(lambda (r1 r2 equal?)
|
||||
(and #,@(map-with-index (lambda (i field-spec)
|
||||
#`(equal? (raw-generic-access r1 #,i)
|
||||
(raw-generic-access r2 #,i)))
|
||||
(syntax->list #'(?field-spec ...)))))))
|
||||
|
||||
|
||||
#'(begin
|
||||
contract
|
||||
;; the contract might be used in the definitions, hence this ordering
|
||||
defs)))))))
|
||||
(with-syntax
|
||||
((defs
|
||||
#'(begin
|
||||
(define-values (type-descriptor
|
||||
raw-constructor
|
||||
raw-predicate
|
||||
raw-generic-access
|
||||
raw-generic-mutate)
|
||||
(make-struct-type
|
||||
'?type-name #f (+ 1 number-of-fields) 0
|
||||
#f
|
||||
(list
|
||||
(cons prop:print-convert-constructor-name
|
||||
'?constructor)
|
||||
(cons prop:custom-write
|
||||
(lambda (r port write?)
|
||||
(custom-write-record '?type-name
|
||||
(access-record-fields r raw-generic-access number-of-fields)
|
||||
port write?)))
|
||||
(cons prop:equal+hash
|
||||
(list record-equal? void void))
|
||||
(cons prop:lazy-wrap
|
||||
(make-lazy-wrap-info constructor-proc
|
||||
(list raw-accessor-proc ...)
|
||||
(list raw-mutator-proc ...)
|
||||
(lambda (r)
|
||||
(raw-generic-access r number-of-fields))
|
||||
(lambda (r val)
|
||||
(raw-generic-mutate r number-of-fields val)))))
|
||||
(make-inspector)))
|
||||
(define ?constructor constructor-proc)
|
||||
(define-values (?predicate real-predicate)
|
||||
(values predicate-proc predicate-proc))
|
||||
(define-values (accessor ... our-accessor ...)
|
||||
(values accessor-proc ... accessor-proc ...))
|
||||
(define mutator mutator-proc) ...))
|
||||
(contract
|
||||
(with-syntax (((?param ...) (generate-temporaries #'(?field-spec ...))))
|
||||
(with-syntax (((component-contract ...)
|
||||
(map (lambda (accessor param)
|
||||
(with-syntax ((?accessor accessor)
|
||||
(?param param))
|
||||
#'(at ?param (property ?accessor ?param))))
|
||||
(syntax->list #'(our-accessor ...))
|
||||
(syntax->list #'(?param ...)))))
|
||||
(with-syntax ((base-contract
|
||||
(stepper-syntax-property
|
||||
#'(define ?type-name
|
||||
(contract (predicate real-predicate)))
|
||||
'stepper-skip-completely
|
||||
#t))
|
||||
(constructor-contract
|
||||
(stepper-syntax-property
|
||||
(if (syntax->datum #'?mutable?)
|
||||
;; no lazy contracts
|
||||
#'(define (?contract-constructor-name ?param ...)
|
||||
(contract
|
||||
(combined (at ?type-name (predicate real-predicate))
|
||||
component-contract ...)))
|
||||
;; lazy contracts
|
||||
#'(define (?contract-constructor-name ?param ...)
|
||||
(make-struct-wrap-contract '?type-name type-descriptor (list ?param ...) #'?type-name)))
|
||||
'stepper-skip-completely
|
||||
#t)))
|
||||
#'(begin
|
||||
;; we use real-predicate to avoid infinite recursion if a contract
|
||||
;; for ?type-name using ?predicate is inadvertently defined
|
||||
base-contract
|
||||
constructor-contract))))))
|
||||
(with-syntax ((defs
|
||||
(stepper-syntax-property
|
||||
(syntax/loc x defs) 'stepper-skip-completely #t)))
|
||||
|
||||
#'(begin
|
||||
contract
|
||||
;; the contract might be used in the definitions, hence this ordering
|
||||
defs))))))
|
||||
|
||||
((_ ?type-name
|
||||
?contract-constructor-name
|
||||
|
@ -295,7 +319,7 @@ prints as:
|
|||
(with-syntax (((dummy-mutator ...)
|
||||
(generate-temporaries (syntax (accessor ...)))))
|
||||
(syntax
|
||||
(define-record-procedures* ?type-name
|
||||
(define-record-procedures* ?type-name #f
|
||||
dummy-contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
|
@ -362,7 +386,7 @@ prints as:
|
|||
(with-syntax (((dummy-mutator ...)
|
||||
(generate-temporaries (syntax (accessor ...)))))
|
||||
(syntax
|
||||
(define-record-procedures* ?type-name ?contract-constructor-name
|
||||
(define-record-procedures* ?type-name #f ?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
((accessor dummy-mutator) ...))))))
|
||||
|
@ -424,7 +448,7 @@ prints as:
|
|||
"Selektor ist kein Bezeichner"))))
|
||||
(syntax->list (syntax (?field-spec ...))))
|
||||
|
||||
#'(define-record-procedures* ?type-name
|
||||
#'(define-record-procedures* ?type-name #t
|
||||
dummy-contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
|
@ -486,7 +510,7 @@ prints as:
|
|||
"Selektor ist kein Bezeichner"))))
|
||||
(syntax->list (syntax (?field-spec ...))))
|
||||
|
||||
#'(define-record-procedures* ?type-name ?contract-constructor-name
|
||||
#'(define-record-procedures* ?type-name #t ?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
(?field-spec ...))))
|
||||
|
|
|
@ -6,11 +6,13 @@
|
|||
define-record-procedures-parametric-2)
|
||||
|
||||
(require scheme/include
|
||||
scheme/promise
|
||||
mzlib/struct
|
||||
mzlib/pconvert-prop
|
||||
mzlib/pretty
|
||||
deinprogramm/contract/contract
|
||||
deinprogramm/contract/contract-syntax)
|
||||
|
||||
(require deinprogramm/deinprogramm-struct)
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax deinprogramm/syntax-checkers)
|
||||
(for-syntax stepper/private/shared))
|
||||
|
|
|
@ -21,10 +21,6 @@
|
|||
wxme/wxme
|
||||
setup/dirs
|
||||
|
||||
;; this module is shared between the drscheme's namespace (so loaded here)
|
||||
;; and the user's namespace in the teaching languages
|
||||
"deinprogramm-struct.ss"
|
||||
|
||||
lang/stepper-language-interface
|
||||
lang/debugger-language-interface
|
||||
lang/run-teaching-program
|
||||
|
@ -171,8 +167,6 @@
|
|||
|
||||
(define/override (on-execute settings run-in-user-thread)
|
||||
(let ([drs-namespace (current-namespace)]
|
||||
[deinprogramm-struct-module-name
|
||||
((current-module-name-resolver) '(lib "deinprogramm/deinprogramm-struct.ss") #f #f)]
|
||||
[scheme-test-module-name
|
||||
((current-module-name-resolver) '(lib "test-engine/scheme-tests.ss") #f #f)]
|
||||
[scheme-contract-module-name
|
||||
|
@ -182,7 +176,6 @@
|
|||
(read-accept-quasiquote (get-accept-quasiquote?))
|
||||
(ensure-drscheme-secrets-declared drs-namespace)
|
||||
(namespace-attach-module drs-namespace ''drscheme-secrets)
|
||||
(namespace-attach-module drs-namespace deinprogramm-struct-module-name)
|
||||
(error-display-handler teaching-languages-error-display-handler)
|
||||
|
||||
(current-eval (add-annotation (deinprogramm-lang-settings-tracing? settings) (current-eval)))
|
||||
|
|
|
@ -1,6 +0,0 @@
|
|||
#lang scheme/base
|
||||
(provide prop:deinprogramm-struct
|
||||
deinprogramm-struct?)
|
||||
|
||||
(define-values (prop:deinprogramm-struct deinprogramm-struct? deinprogramm-struct-ref)
|
||||
(make-struct-type-property 'deinprogramm-struct))
|
|
@ -45,7 +45,11 @@ Mutators sein.
|
|||
|
||||
@defform[(define-record-procedures-parametric-2 t cc c p (field-spec1 ...))]{
|
||||
Diese Form ist wie @scheme[define-record-procedures-2], nur parametrisch
|
||||
wie @schemeidfont{define-record-procedures-parametric}.}
|
||||
wie @schemeidfont{define-record-procedures-parametric}. Außerdem
|
||||
werden die Verträge für die Feldinhalte, anders als bei
|
||||
@scheme[define-record-procedures-parametric], sofort bei der
|
||||
Konstruktion überprüft und nicht erst beim Aufruf eines Selektors.
|
||||
}
|
||||
|
||||
@section{@scheme[set!]}
|
||||
|
||||
|
|
|
@ -368,6 +368,9 @@ Beispiel:
|
|||
Dann ist @scheme[(pare-of integer string)] der Vertrag für
|
||||
@scheme[pare]-Records, bei dem die Feldinhalte die Verträge
|
||||
@scheme[integer] bzw. @scheme[string] erfüllen müssen.
|
||||
|
||||
Die Verträge für die Feldinhalte werden erst überprüft, wenn ein
|
||||
Selektor aufgerufen wird.
|
||||
}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
|
|
@ -3,6 +3,7 @@
|
|||
(provide all-contract-tests)
|
||||
|
||||
(require schemeunit
|
||||
deinprogramm/define-record-procedures
|
||||
deinprogramm/contract/contract
|
||||
deinprogramm/contract/contract-syntax)
|
||||
|
||||
|
@ -251,6 +252,97 @@
|
|||
(let ((proc (say-no (apply-contract int->bool (lambda (x) (+ x 1))))))
|
||||
(check-equal? (say-no (proc 12)) 'no)))
|
||||
|
||||
|
||||
(test-case
|
||||
"record-wrap"
|
||||
(define-record-procedures-parametric pare pare-of kons pare? (kar kdr))
|
||||
(define ctr (pare-of integer boolean))
|
||||
(let ((obj (apply-contract ctr (kons 1 #t))))
|
||||
(check-equal? (kar obj) 1)
|
||||
(check-equal? (kdr obj) #t))
|
||||
(let ((obj (apply-contract ctr (kons 1 2))))
|
||||
(check-equal? (say-no (kar obj)) 'no))
|
||||
)
|
||||
|
||||
(test-case
|
||||
"record-wrap-2"
|
||||
(let ((count 0))
|
||||
(define counting-integer
|
||||
(make-predicate-contract 'counting-integer
|
||||
(lambda (obj)
|
||||
(set! count (+ 1 count))
|
||||
(integer? obj))
|
||||
'integer-marker))
|
||||
(define-record-procedures-parametric pare pare-of kons pare? (kar kdr))
|
||||
(define ctr (contract (pare-of counting-integer boolean)))
|
||||
(let ((obj (apply-contract ctr (apply-contract ctr (kons 1 #t)))))
|
||||
(check-equal? count 0)
|
||||
(check-equal? (kar obj) 1)
|
||||
(check-equal? count 1)
|
||||
(check-equal? (kdr obj) #t)
|
||||
(check-equal? count 1))))
|
||||
|
||||
(test-case
|
||||
"double-wrap"
|
||||
(let ((count 0))
|
||||
(define counting-integer
|
||||
(make-predicate-contract 'counting-integer
|
||||
(lambda (obj)
|
||||
(set! count (+ 1 count))
|
||||
(integer? obj))
|
||||
'integer-marker))
|
||||
(define-record-procedures-parametric pare pare-of raw-kons pare? (kar kdr))
|
||||
|
||||
(define empty-list (contract (predicate null?)))
|
||||
|
||||
(define list-of
|
||||
(lambda (x)
|
||||
(contract (mixed empty-list
|
||||
(pare-of x (list-of x))))))
|
||||
|
||||
(define/contract kons (contract (%a (list-of %a) -> (pare-of %a (list-of %a))))
|
||||
raw-kons)
|
||||
|
||||
(define/contract build-list (contract (integer -> (list-of counting-integer)))
|
||||
(lambda (n)
|
||||
(if (= n 0)
|
||||
'()
|
||||
(kons n (build-list (- n 1))))))
|
||||
|
||||
(define/contract list-length (contract ((list-of counting-integer) -> integer))
|
||||
(lambda (lis)
|
||||
(cond
|
||||
((null? lis) 0)
|
||||
((pare? lis)
|
||||
(+ 1 (list-length (kdr lis)))))))
|
||||
|
||||
;; one wrap each for (list-of %a), one for (list-of counting-integer)
|
||||
(let ((l1 (build-list 10)))
|
||||
(check-equal? count 0)
|
||||
(let ((len1 (list-length l1)))
|
||||
(check-equal? count 10)))))
|
||||
|
||||
(test-case
|
||||
"wrap equality"
|
||||
(define-record-procedures-parametric pare pare-of raw-kons pare? (kar kdr))
|
||||
|
||||
(define empty-list (contract (predicate null?)))
|
||||
|
||||
(define list-of
|
||||
(lambda (x)
|
||||
(contract (mixed empty-list
|
||||
(pare-of x (list-of x))))))
|
||||
|
||||
(define/contract kons (contract (%a (list-of %a) -> (pare-of %a (list-of %a))))
|
||||
raw-kons)
|
||||
|
||||
(check-equal? (raw-kons 1 '()) (raw-kons 1 '()))
|
||||
(check-equal? (kons 1 '()) (kons 1 '()))
|
||||
(check-equal? (kons 1 '()) (raw-kons 1 '()))
|
||||
(check-equal? (raw-kons 1 '()) (kons 1 '())))
|
||||
|
||||
|
||||
|
||||
))
|
||||
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user