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

Typos and type errors in new property stuff.

Browse Source 
svn: r17700
This commit is contained in:
Carl Eastlund 2010-01-17 07:23:47 +00:00
parent 1f969b8831
commit bb7bd9de51
5 changed files with 29 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/private/contract-arr-obj-helpers.ss
View File

@ -365,7 +365,7 @@
[(val blame name-id) outer-args]) [(val blame name-id) outer-args])
(syntax (syntax
(let ([dom-contract-x (coerce-contract '-> dom)] ...) (let ([dom-contract-x (coerce-contract '-> dom)] ...)
(let ([dom-x (contract-proc dom-contract-x)] ...) (let ([dom-x (contract-projection dom-contract-x)] ...)
(let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)]) (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)])
body)))))) body))))))

4
collects/mzlib/private/contract-object.ss
View File

@ -331,9 +331,9 @@
... ...
[field-ctc-var (coerce-contract 'object-contract field-ctc-stx)] [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
...) ...)
(let ([method-var (contract-proc method-ctc-var)] (let ([method-var (contract-projection method-ctc-var)]
... ...
[field-var (contract-proc field-ctc-var)] [field-var (contract-projection field-ctc-var)]
...) ...)
(let ([cls (make-wrapper-class 'wrapper-class (let ([cls (make-wrapper-class 'wrapper-class
'(method-name ...) '(method-name ...)

16
collects/scheme/contract/private/base.ss
View File

@ -57,13 +57,15 @@ improve method arity mismatch contract violation error messages?
[(syntax? info) (build-source-location info)] [(syntax? info) (build-source-location info)]
[(list? info) [(list? info)
(let ([loc (list-ref info 0)]) (let ([loc (list-ref info 0)])
(struct-copy (if (syntax? (srcloc-source loc))
srcloc loc (struct-copy
[source srcloc loc
(resolved-module-path-name [source
(module-path-index-resolve (resolved-module-path-name
(syntax-source-module (module-path-index-resolve
(srcloc-source loc))))]))] (syntax-source-module
(srcloc-source loc))))])
loc))]
[else [else
(error 'contract (error 'contract
"expected a syntax object or list of two elements, got: ~e" "expected a syntax object or list of two elements, got: ~e"

20
collects/scheme/contract/private/helpers.ss
View File

@ -109,14 +109,18 @@
(syntax-line stx) (syntax-line stx)
(syntax-column stx) (syntax-column stx)
(syntax-position stx)) (syntax-position stx))
(values (source->name (if (syntax? (srcloc-source stx))
(resolved-module-path-name (values (source->name
(module-path-index-resolve (resolved-module-path-name
(syntax-source-module (module-path-index-resolve
(srcloc-source stx))))) (syntax-source-module
(srcloc-line stx) (srcloc-source stx)))))
(srcloc-column stx) (srcloc-line stx)
(srcloc-position stx)))]) (srcloc-column stx)
(srcloc-position stx))
(error 'contract
"malformed srcloc has non-syntax source: ~e"
stx)))])
(let ([location (cond [(and line col) (format "~a:~a" line col)] (let ([location (cond [(and line col) (format "~a:~a" line col)]
[pos (format "~a" pos)] [pos (format "~a" pos)]
[else #f])]) [else #f])])

11
collects/scheme/contract/private/misc.ss
View File

@ -740,7 +740,7 @@
'type-name 'type-name
val)) val))
(fill-name p-app val)))) (fill-name p-app val))))
predicate?)))))))])) #:first-order predicate?)))))))]))
(define listof (define listof
(*-immutableof list? map andmap list listof)) (*-immutableof list? map andmap list listof))
@ -902,8 +902,7 @@
"expected immutable <~a>, given: ~e" "expected immutable <~a>, given: ~e"
"expected <~a>, given: ~e") "expected <~a>, given: ~e")
'type-name 'type-name
v))))) v)))))))))))))]
#f))))))))]
[(_ predicate? constructor (arb? selector) correct-size type-name name) [(_ predicate? constructor (arb? selector) correct-size type-name name)
(eq? #t (syntax->datum (syntax arb?))) (eq? #t (syntax->datum (syntax arb?)))
(syntax (syntax
@ -936,8 +935,7 @@
v v
"expected <~a>, given: ~e" "expected <~a>, given: ~e"
'type-name 'type-name
v))))) v)))))))))))]))
#f))))))]))
(define cons/c (*-immutable/c pair? cons (#f car cdr) cons cons/c #f)) (define cons/c (*-immutable/c pair? cons (#f car cdr) cons cons/c #f))
(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c)) (define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
@ -1012,6 +1010,7 @@
[ctc-proc (contract-projection ctc)]) [ctc-proc (contract-projection ctc)])
(simple-contract (simple-contract
#:name (build-compound-type-name 'promise/c ctc) #:name (build-compound-type-name 'promise/c ctc)
#:projection
(λ (blame) (λ (blame)
(let ([p-app (ctc-proc blame)]) (let ([p-app (ctc-proc blame)])
(λ (val) (λ (val)
@ -1022,7 +1021,7 @@
"expected <promise>, given: ~e" "expected <promise>, given: ~e"
val)) val))
(delay (p-app (force val)))))) (delay (p-app (force val))))))
promise?)))) #:first-order promise?))))
#| #|
as with copy-struct in struct.ss, this first begin0 as with copy-struct in struct.ss, this first begin0