..
original commit: 2a6090270b1766d7b4798afd8171a5c5f953ca60
This commit is contained in:
Robby Findler
parent
1f91794eea
commit
0826088493
|
|
@ -822,75 +822,74 @@
|
||||||
(and
|
(and
|
||||||
(andmap method-specifier? (syntax->list (syntax (method-specifier ...))))
|
(andmap method-specifier? (syntax->list (syntax (method-specifier ...))))
|
||||||
(andmap identifier? (syntax->list (syntax (meth-name ...)))))
|
(andmap identifier? (syntax->list (syntax (meth-name ...)))))
|
||||||
(match-let ([(`(,make-outer-checks ,xxx ,build-pieces) ...)
|
(let* ([outer-args (syntax (val pos-blame neg-blame src-info))]
|
||||||
(map (lambda (meth-contract-stx)
|
[val-meth-names (syntax->list (syntax (meth-name ...)))]
|
||||||
(let ([/h (select/h meth-contract-stx 'class-contract stx)])
|
[val-publics? (map (lambda (x) (eq? 'public (syntax-e x)))
|
||||||
(let-values ([(make-outer-check xxx build-pieces impl-wrap impl-builder impl-info)
|
(syntax->list (syntax (method-specifier ...))))]
|
||||||
(/h meth-contract-stx)])
|
[super-meth-names (map prefix-super val-meth-names)]
|
||||||
(list make-outer-check xxx build-pieces))))
|
[val-meth-contracts (syntax->list (syntax (meth-contract ...)))]
|
||||||
(syntax->list (syntax (meth-contract ...))))])
|
[val-meth-contract-vars (generate-temporaries val-meth-contracts)])
|
||||||
(let* ([outer-args (syntax (val pos-blame neg-blame src-info))]
|
|
||||||
[val-meth-names (syntax->list (syntax (meth-name ...)))]
|
(let ([ht (make-hash-table)])
|
||||||
[val-publics? (map (lambda (x) (eq? 'public (syntax-e x)))
|
(for-each (lambda (name)
|
||||||
(syntax->list (syntax (method-specifier ...))))]
|
(let ([key (syntax-e name)])
|
||||||
[super-meth-names (map prefix-super val-meth-names)]
|
(when (hash-table-get ht key (lambda () #f))
|
||||||
[val-meth-contracts (syntax->list (syntax (meth-contract ...)))]
|
(raise-syntax-error 'class/contract "duplicate method name in contract" stx name))
|
||||||
[val-meth-contract-vars (generate-temporaries val-meth-contracts)])
|
(hash-table-put! ht key #t)))
|
||||||
(with-syntax ([outer-args outer-args]
|
val-meth-names))
|
||||||
[(super-meth-name ...) super-meth-names]
|
|
||||||
[(get-meth-contract ...) (map method-name->contract-method-name val-meth-names)]
|
(with-syntax ([outer-args outer-args]
|
||||||
[(method ...) (map (lambda (meth-name meth-contract-var contract-stx public?)
|
[(super-meth-name ...) super-meth-names]
|
||||||
(if public?
|
[(get-meth-contract ...) (map method-name->contract-method-name val-meth-names)]
|
||||||
(make-wrapper-method outer-args meth-name meth-contract-var contract-stx)
|
[(method ...) (map (lambda (meth-name meth-contract-var contract-stx public?)
|
||||||
(make-wrapper-method/impl outer-args meth-name meth-contract-var contract-stx)))
|
(if public?
|
||||||
val-meth-names
|
(make-wrapper-method outer-args meth-name meth-contract-var contract-stx)
|
||||||
val-meth-contract-vars
|
(make-wrapper-method/impl outer-args meth-name meth-contract-var contract-stx)))
|
||||||
val-meth-contracts
|
val-meth-names
|
||||||
val-publics?)]
|
val-meth-contract-vars
|
||||||
[(meth-contract-var ...) val-meth-contract-vars]
|
val-meth-contracts
|
||||||
[(method-contract-declarations ...) (map (lambda (meth-name meth-contract-var public?)
|
val-publics?)]
|
||||||
(if public?
|
[(meth-contract-var ...) val-meth-contract-vars]
|
||||||
(make-public-method-contract-declaration meth-name meth-contract-var)
|
[(method-contract-declarations ...) (map (lambda (meth-name meth-contract-var public?)
|
||||||
(make-override-method-contract-declaration meth-name meth-contract-var)))
|
(if public?
|
||||||
val-meth-names
|
(make-public-method-contract-declaration meth-name meth-contract-var)
|
||||||
val-meth-contract-vars
|
(make-override-method-contract-declaration meth-name meth-contract-var)))
|
||||||
val-publics?)])
|
val-meth-names
|
||||||
(foldr
|
val-meth-contract-vars
|
||||||
(lambda (f stx) (f stx))
|
val-publics?)])
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(let ([meth-contract-var meth-contract] ...)
|
(let ([meth-contract-var meth-contract] ...)
|
||||||
(make-contract
|
(make-contract
|
||||||
(lambda outer-args
|
(lambda outer-args
|
||||||
(unless (class? val)
|
(unless (class? val)
|
||||||
(raise-contract-error src-info pos-blame neg-blame "expected a class, got: ~e" val))
|
(raise-contract-error src-info pos-blame neg-blame "expected a class, got: ~e" val))
|
||||||
(let ([class-i (class->interface val)])
|
(let ([class-i (class->interface val)])
|
||||||
(void)
|
(void)
|
||||||
(unless (method-in-interface? 'meth-name class-i)
|
(unless (method-in-interface? 'meth-name class-i)
|
||||||
(raise-contract-error src-info
|
(raise-contract-error src-info
|
||||||
pos-blame
|
pos-blame
|
||||||
neg-blame
|
neg-blame
|
||||||
"expected class to have method ~a, got: ~e"
|
"expected class to have method ~a, got: ~e"
|
||||||
'meth-name
|
'meth-name
|
||||||
val))
|
val))
|
||||||
...
|
...
|
||||||
|
|
||||||
(let ([override-spec? (eq? 'override 'method-specifier)]
|
(let ([override-spec? (eq? 'override 'method-specifier)]
|
||||||
[override? (method-in-interface? 'get-meth-contract class-i)])
|
[override? (method-in-interface? 'get-meth-contract class-i)])
|
||||||
(unless (boolean=? override-spec? override?)
|
(unless (boolean=? override-spec? override?)
|
||||||
(if override-spec?
|
(if override-spec?
|
||||||
(error 'class-contract "method ~a is declared as an overriding method in ~e, but isn't" 'meth-name val)
|
(error 'class-contract "method ~a is declared as an overriding method in ~e, but isn't" 'meth-name val)
|
||||||
(error 'class-contract "method ~a is declared as a public method in ~e, but isn't" 'meth-name val))))
|
(error 'class-contract "method ~a is declared as a public method in ~e, but isn't" 'meth-name val))))
|
||||||
...)
|
...)
|
||||||
|
|
||||||
(class val
|
(class val
|
||||||
|
|
||||||
method-contract-declarations ...
|
method-contract-declarations ...
|
||||||
|
|
||||||
(rename [super-meth-name meth-name] ...)
|
(rename [super-meth-name meth-name] ...)
|
||||||
method ...
|
method ...
|
||||||
(super-instantiate ())))
|
(super-instantiate ())))
|
||||||
(lambda x (error 'impl-contract "unimplemented")))))
|
(lambda x (error 'impl-contract "unimplemented")))))))]
|
||||||
make-outer-checks))))]
|
|
||||||
[(_ (meth-specifier meth-name meth-contract) ...)
|
[(_ (meth-specifier meth-name meth-contract) ...)
|
||||||
(for-each (lambda (specifier name)
|
(for-each (lambda (specifier name)
|
||||||
(unless (method-specifier? name)
|
(unless (method-specifier? name)
|
||||||
|
|
@ -1570,8 +1569,10 @@
|
||||||
((contract-wrap (car contracts)) val pos neg src-info)]))
|
((contract-wrap (car contracts)) val pos neg src-info)]))
|
||||||
(lambda x (error 'impl-contract "unimplemented")))])))
|
(lambda x (error 'impl-contract "unimplemented")))])))
|
||||||
|
|
||||||
(provide and/f or/f
|
(provide and/f or/f not/f
|
||||||
>=/c <=/c </c >/c
|
>=/c <=/c </c >/c
|
||||||
|
integer-in real-in
|
||||||
|
string/len
|
||||||
natural-number?
|
natural-number?
|
||||||
false? any?
|
false? any?
|
||||||
printable?
|
printable?
|
||||||
|
|
@ -1608,6 +1609,15 @@
|
||||||
(cons (car strs)
|
(cons (car strs)
|
||||||
(loop (cdr strs))))]))))))
|
(loop (cdr strs))))]))))))
|
||||||
|
|
||||||
|
(define (string/len n)
|
||||||
|
(unless (number? n)
|
||||||
|
(error 'string/len "expected a number as argument, got ~e" n))
|
||||||
|
(make-flat-named-contract
|
||||||
|
(format "string (up to ~a characters)" n)
|
||||||
|
(lambda (x)
|
||||||
|
(and (string? x)
|
||||||
|
((string-length x) . < . n)))))
|
||||||
|
|
||||||
(define (symbols . ss)
|
(define (symbols . ss)
|
||||||
(unless ((length ss) . >= . 1)
|
(unless ((length ss) . >= . 1)
|
||||||
(error 'symbols "expected at least one argument"))
|
(error 'symbols "expected at least one argument"))
|
||||||
|
|
@ -1653,7 +1663,7 @@
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(andmap (lambda (f) (test-flat-contract f x))
|
(andmap (lambda (f) (test-flat-contract f x))
|
||||||
fs))))
|
fs))))
|
||||||
|
|
||||||
(define (or/f . fs)
|
(define (or/f . fs)
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
|
|
@ -1667,6 +1677,16 @@
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(ormap (lambda (f) (test-flat-contract f x))
|
(ormap (lambda (f) (test-flat-contract f x))
|
||||||
fs))))
|
fs))))
|
||||||
|
|
||||||
|
(define (not/f f)
|
||||||
|
(unless (or (flat-named-contract? f)
|
||||||
|
(and (procedure? f)
|
||||||
|
(procedure-arity-includes? f 1)))
|
||||||
|
(error 'not/f "expected a procedure of arity 1 or <flat-named-contract>, given: ~e" f))
|
||||||
|
(make-flat-named-contract
|
||||||
|
(build-compound-type-name "not/f" f)
|
||||||
|
(lambda (x)
|
||||||
|
(not (f x)))))
|
||||||
|
|
||||||
(define (>=/c x)
|
(define (>=/c x)
|
||||||
(make-flat-named-contract
|
(make-flat-named-contract
|
||||||
|
|
@ -1728,7 +1748,7 @@
|
||||||
(make-flat-named-contract
|
(make-flat-named-contract
|
||||||
"false"
|
"false"
|
||||||
(lambda (x) (not x))))
|
(lambda (x) (not x))))
|
||||||
|
|
||||||
(define any?
|
(define any?
|
||||||
(make-flat-named-contract
|
(make-flat-named-contract
|
||||||
"any"
|
"any"
|
||||||
|
|
@ -1773,6 +1793,26 @@
|
||||||
args
|
args
|
||||||
(vector->list v))))))
|
(vector->list v))))))
|
||||||
|
|
||||||
|
(define (integer-in start end)
|
||||||
|
(unless (and (integer? start)
|
||||||
|
(integer? end))
|
||||||
|
(error 'integer-in "expected two integers as arguments, got ~e and ~e" start end))
|
||||||
|
(make-flat-named-contract
|
||||||
|
(format "integer between ~a and ~a, inclusive" start end)
|
||||||
|
(lambda (x)
|
||||||
|
(and (integer? x)
|
||||||
|
(<= start x end)))))
|
||||||
|
|
||||||
|
(define (real-in start end)
|
||||||
|
(unless (and (real? start)
|
||||||
|
(real? end))
|
||||||
|
(error 'real-in "expected two real numbers as arguments, got ~e and ~e" start end))
|
||||||
|
(make-flat-named-contract
|
||||||
|
(format "real between ~a and ~a, inclusive" start end)
|
||||||
|
(lambda (x)
|
||||||
|
(and (real? x)
|
||||||
|
(<= start x end)))))
|
||||||
|
|
||||||
(define (box/p pred)
|
(define (box/p pred)
|
||||||
(unless (flat-contract? pred)
|
(unless (flat-contract? pred)
|
||||||
(error 'box/p "expected a flat contract, got: ~e" pred))
|
(error 'box/p "expected a flat contract, got: ~e" pred))
|
||||||
|
|
|
||||||
|
|
@ -881,6 +881,22 @@
|
||||||
(send (make-object d%) m 100))
|
(send (make-object d%) m 100))
|
||||||
"pos-d")
|
"pos-d")
|
||||||
|
|
||||||
|
(test/spec-failed
|
||||||
|
'not/f1
|
||||||
|
'(contract (not/f integer?)
|
||||||
|
1
|
||||||
|
'pos
|
||||||
|
'neg)
|
||||||
|
"pos-d")
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'not/f2
|
||||||
|
'(contract (not/f integer?)
|
||||||
|
'not-integer
|
||||||
|
'pos
|
||||||
|
'neg)
|
||||||
|
'not-integer)
|
||||||
|
|
||||||
))
|
))
|
||||||
|
|
||||||
(report-errs)
|
(report-errs)
|
||||||
Loading…
Reference in New Issue
Block a user