Restored legacy functions for custom contracts.
svn: r17900
This commit is contained in:
Carl Eastlund
parent
2513e7d6e0
commit
2772ffccba
|
|
@ -8,6 +8,7 @@
|
|||
"private/misc.ss"
|
||||
"private/provide.ss"
|
||||
"private/guts.ss"
|
||||
"private/legacy.ss"
|
||||
"private/ds.ss"
|
||||
"private/opt.ss")
|
||||
|
||||
|
|
@ -26,6 +27,10 @@
|
|||
check-unary-between/c)
|
||||
(all-from-out "private/provide.ss")
|
||||
(all-from-out "private/base.ss")
|
||||
(except-out (all-from-out "private/legacy.ss")
|
||||
unpack-blame
|
||||
unpack-source
|
||||
unpack-name)
|
||||
(except-out (all-from-out "private/guts.ss")
|
||||
check-flat-contract
|
||||
check-flat-named-contract))
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ improve method arity mismatch contract violation error messages?
|
|||
unstable/srcloc
|
||||
unstable/location
|
||||
"guts.ss"
|
||||
"helpers.ss")
|
||||
"legacy.ss")
|
||||
|
||||
(define-syntax-parameter current-contract-region
|
||||
(λ (stx) #'(quote-module-path)))
|
||||
|
|
@ -30,19 +30,20 @@ improve method arity mismatch contract violation error messages?
|
|||
(apply-contract c v pos neg name loc))]
|
||||
[(_ c v pos neg)
|
||||
(syntax/loc stx
|
||||
(apply-contract c v pos neg #f (build-source-location #f)))]
|
||||
[(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e)
|
||||
#|
|
||||
(apply-contract c
|
||||
v
|
||||
(unpack-blame pos)
|
||||
(unpack-blame neg)
|
||||
#f
|
||||
(build-source-location #f)))]
|
||||
[(_ c v pos neg src)
|
||||
(syntax/loc stx
|
||||
(let* ([info src-info-e])
|
||||
(contract a-contract-e
|
||||
to-check
|
||||
pos-blame-e
|
||||
neg-blame-e
|
||||
(unpack-source info)
|
||||
(unpack-name info))))
|
||||
|#
|
||||
(raise-syntax-error 'contract "upgrade to new calling convention" stx)]))
|
||||
(apply-contract c
|
||||
v
|
||||
(unpack-blame pos)
|
||||
(unpack-blame neg)
|
||||
(unpack-name src)
|
||||
(unpack-source src)))]))
|
||||
|
||||
(define (apply-contract c v pos neg name loc)
|
||||
(let* ([c (coerce-contract 'contract c)]
|
||||
|
|
@ -92,34 +93,6 @@ improve method arity mismatch contract violation error messages?
|
|||
"all arguments: ~e")
|
||||
v-name v x args)])))))
|
||||
|
||||
(define (unpack-source info)
|
||||
(cond
|
||||
[(syntax? info) (build-source-location info)]
|
||||
[(list? info)
|
||||
(let ([loc (list-ref info 0)])
|
||||
(if (syntax? (srcloc-source loc))
|
||||
(struct-copy
|
||||
srcloc loc
|
||||
[source
|
||||
(resolved-module-path-name
|
||||
(module-path-index-resolve
|
||||
(syntax-source-module
|
||||
(srcloc-source loc))))])
|
||||
loc))]
|
||||
[else
|
||||
(error 'contract
|
||||
"expected a syntax object or list of two elements, got: ~e"
|
||||
info)]))
|
||||
|
||||
(define (unpack-name info)
|
||||
(cond
|
||||
[(syntax? info) (and (identifier? info) (syntax-e info))]
|
||||
[(list? info) (list-ref info 1)]
|
||||
[else
|
||||
(error 'contract
|
||||
"expected a syntax object or list of two elements, got: ~e"
|
||||
info)]))
|
||||
|
||||
(define-syntax (recursive-contract stx)
|
||||
(syntax-case stx ()
|
||||
[(_ arg)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#lang scheme/base
|
||||
|
||||
(provide unpack-blame
|
||||
mangle-id mangle-id-for-maker
|
||||
(provide mangle-id mangle-id-for-maker
|
||||
build-struct-names
|
||||
lookup-struct-info
|
||||
nums-up-to
|
||||
|
|
@ -128,23 +127,6 @@
|
|||
(string-append source ":" location)
|
||||
(or location source)))))
|
||||
|
||||
;; unpack-blame : any/c -> any/c
|
||||
;; Constructs an S-expression for use in the blame error messages.
|
||||
;; A variable reference represents a module or top-level context.
|
||||
;; Other representations of blame are returned as-is.
|
||||
(define (unpack-blame blame)
|
||||
(if (variable-reference? blame)
|
||||
(let ([rp (variable-reference->resolved-module-path blame)])
|
||||
(cond
|
||||
[(not rp)
|
||||
'top-level]
|
||||
[else
|
||||
(let ([resolved (resolved-module-path-name rp)])
|
||||
(cond
|
||||
[(symbol? resolved) `(quote ,resolved)]
|
||||
[else `(file ,(path->string resolved))]))]))
|
||||
blame))
|
||||
|
||||
(define build-struct-names
|
||||
(lambda (name-stx fields omit-sel? omit-set? srcloc-stx)
|
||||
(let ([name (symbol->string (syntax-e name-stx))]
|
||||
|
|
|
|||
126
collects/scheme/contract/private/legacy.ss
Normal file
126
collects/scheme/contract/private/legacy.ss
Normal file
|
|
@ -0,0 +1,126 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "guts.ss" "blame.ss" unstable/srcloc)
|
||||
|
||||
(provide make-proj-contract
|
||||
raise-contract-error
|
||||
contract-proc
|
||||
|
||||
proj-prop proj-get proj-pred?
|
||||
name-prop name-get name-pred?
|
||||
stronger-prop stronger-get stronger-pred?
|
||||
first-order-prop first-order-get first-order-pred?
|
||||
flat-prop flat-get flat-pred?
|
||||
|
||||
unpack-blame unpack-source unpack-name
|
||||
|
||||
)
|
||||
|
||||
(define (raise-contract-error x src pos name fmt . args)
|
||||
(apply raise-blame-error
|
||||
(make-blame (unpack-source src)
|
||||
(unpack-name src)
|
||||
name
|
||||
(unpack-blame pos)
|
||||
"<<unknown party>>"
|
||||
#f)
|
||||
x
|
||||
fmt
|
||||
args))
|
||||
|
||||
(define (make-proj-contract name proj test)
|
||||
(simple-contract
|
||||
#:name name
|
||||
#:first-order test
|
||||
#:projection
|
||||
(lambda (blame)
|
||||
(proj (blame-guilty blame)
|
||||
(blame-innocent blame)
|
||||
(list (blame-source blame) (blame-value blame))
|
||||
(blame-contract blame)
|
||||
(not (blame-swapped? blame))))))
|
||||
|
||||
(define (contract-proc c)
|
||||
(let* ([proj (contract-projection c)])
|
||||
(lambda (pos neg src name original?)
|
||||
(proj (make-blame (unpack-source src)
|
||||
(unpack-name src)
|
||||
name
|
||||
(unpack-blame (if original? pos neg))
|
||||
(unpack-blame (if original? neg pos))
|
||||
(not original?))))))
|
||||
|
||||
(define (legacy-property name)
|
||||
(define-values [ prop pred get ]
|
||||
(make-struct-type-property
|
||||
name
|
||||
(lambda (impl info)
|
||||
(error
|
||||
name
|
||||
(string-append
|
||||
"this property is a legacy implementation; "
|
||||
"use prop:contract or prop:flat-contract instead.")))))
|
||||
prop)
|
||||
|
||||
(define proj-prop (legacy-property 'proj-prop))
|
||||
(define name-prop (legacy-property 'name-prop))
|
||||
(define stronger-prop (legacy-property 'stronger-prop))
|
||||
(define first-order-prop (legacy-property 'first-order-prop))
|
||||
(define flat-prop (legacy-property 'flat-prop))
|
||||
|
||||
(define proj-pred? contract-struct?)
|
||||
(define name-pred? contract-struct?)
|
||||
(define stronger-pred? contract-struct?)
|
||||
(define first-order-pred? contract-struct?)
|
||||
(define flat-pred? contract-struct?)
|
||||
|
||||
(define (proj-get c) contract-proc)
|
||||
(define (name-get c) contract-name)
|
||||
(define (stronger-get c) contract-stronger?)
|
||||
(define (first-order-get c) contract-first-order)
|
||||
(define (flat-get c) flat-contract-predicate)
|
||||
|
||||
;; unpack-blame : any/c -> any/c
|
||||
;; Constructs an S-expression for use in the blame error messages.
|
||||
;; A variable reference represents a module or top-level context.
|
||||
;; Other representations of blame are returned as-is.
|
||||
(define (unpack-blame blame)
|
||||
(if (variable-reference? blame)
|
||||
(let ([rp (variable-reference->resolved-module-path blame)])
|
||||
(cond
|
||||
[(not rp)
|
||||
'top-level]
|
||||
[else
|
||||
(let ([resolved (resolved-module-path-name rp)])
|
||||
(cond
|
||||
[(symbol? resolved) `(quote ,resolved)]
|
||||
[else `(file ,(path->string resolved))]))]))
|
||||
blame))
|
||||
|
||||
(define (unpack-source info)
|
||||
(cond
|
||||
[(syntax? info) (build-source-location info)]
|
||||
[(list? info)
|
||||
(let ([loc (list-ref info 0)])
|
||||
(if (syntax? (srcloc-source loc))
|
||||
(struct-copy
|
||||
srcloc loc
|
||||
[source
|
||||
(resolved-module-path-name
|
||||
(module-path-index-resolve
|
||||
(syntax-source-module
|
||||
(srcloc-source loc))))])
|
||||
loc))]
|
||||
[else
|
||||
(error 'contract
|
||||
"expected a syntax object or list of two elements, got: ~e"
|
||||
info)]))
|
||||
|
||||
(define (unpack-name info)
|
||||
(cond
|
||||
[(syntax? info) (and (identifier? info) (syntax-e info))]
|
||||
[(list? info) (list-ref info 1)]
|
||||
[else
|
||||
(error 'contract
|
||||
"expected a syntax object or list of two elements, got: ~e"
|
||||
info)]))
|
||||
|
|
@ -7160,7 +7160,64 @@ so that propagation occurs.
|
|||
'pos
|
||||
(compose blame-guilty exn:fail:contract:blame-object)
|
||||
(with-handlers ((void values)) (contract not #t 'pos 'neg))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;
|
||||
;;;;
|
||||
;;;; Legacy Contract Constructor tests
|
||||
;;;;
|
||||
;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; make-proj-contract
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(contract-eval
|
||||
'(define proj:add1->sub1
|
||||
(make-proj-contract
|
||||
'proj:add1->sub1
|
||||
(lambda (pos neg src name blame)
|
||||
(lambda (f)
|
||||
(unless (and (procedure? f) (procedure-arity-includes? f 1))
|
||||
(raise-contract-error f src pos name
|
||||
"expected a unary function, got: ~e"
|
||||
f))
|
||||
(lambda (x)
|
||||
(unless (and (integer? x) (exact? x))
|
||||
(raise-contract-error x src neg name
|
||||
"expected an integer, got: ~e"
|
||||
x))
|
||||
(let* ([y (f (add1 x))])
|
||||
(unless (and (integer? y) (exact? y))
|
||||
(raise-contract-error y src pos name
|
||||
"expected an integer, got: ~e"
|
||||
y))
|
||||
(sub1 y)))))
|
||||
(lambda (f)
|
||||
(and (procedure? f) (procedure-arity-includes? f 1))))))
|
||||
|
||||
(test/spec-passed/result
|
||||
'make-proj-contract-1
|
||||
'((contract proj:add1->sub1 sqrt 'pos 'neg) 15)
|
||||
3)
|
||||
|
||||
(test/pos-blame
|
||||
'make-proj-contract-2
|
||||
'(contract proj:add1->sub1 'dummy 'pos 'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'make-proj-contract-3
|
||||
'((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2))
|
||||
|
||||
(test/neg-blame
|
||||
'make-proj-contract-4
|
||||
'((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy))
|
||||
|
||||
(report-errs)
|
||||
|
||||
))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user