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

..

Browse Source 
original commit: 0e1bf3babada3872e47bed929a6013e007b774cd
This commit is contained in:
Robby Findler 2002-02-23 22:15:33 +00:00
parent f5477f2aa3
commit 6f4abcbe94
2 changed files with 125 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
collects/framework/specs.ss
View File

@ -36,54 +36,72 @@
(identifier? (syntax neg-blame))
(identifier? (syntax pos-blame)))
(syntax-case (syntax a-contract) (-> ->d case-> case->d)
[(->)
(raise-syntax-error
#f
"unknown contract specification"
stx
(syntax type))]
[(-> funs ...)
(with-syntax ([(doms ...) (all-but-last (syntax->list (syntax (funs ...))))]
[rng (car (last-pair (syntax->list (syntax (funs ...)))))]
[arity (- (length (syntax->list (syntax (funs ...))))
1)])
(with-syntax ([(ins ...) (generate-temporaries (syntax (doms ...)))])
(let ()
;; build-single-case : syntax[(listof contracts)] -> syntax[(list syntax[args] syntax)]
;; builds the arguments and result for a single case of a case-lambda or
;; just a single lambda expression.
(define (build-single-case funs)
(with-syntax ([(doms ...) (all-but-last (syntax->list funs))]
[rng (car (last-pair (syntax->list funs)))])
(with-syntax ([(ins ...) (generate-temporaries (syntax (doms ...)))])
(syntax
((ins ...)
(let ([out (name (contract/internal orig-stx doms ins neg-blame pos-blame) ...)])
(contract/internal orig-stx rng out pos-blame neg-blame)))))))
(syntax-case (syntax a-contract) (-> ->d case-> case->d)
[(->)
(raise-syntax-error
#f
"unknown contract specification"
stx
(syntax type))]
[(-> fun funs ...)
(with-syntax ([(args body) (build-single-case (syntax (fun funs ...)))]
[arity (- (length (syntax->list (syntax (fun funs ...))))
1)])
(syntax
(if (and (procedure? name)
(procedure-arity-includes? name arity))
(lambda (ins ...)
(let ([out (name (contract/internal orig-stx doms ins neg-blame pos-blame) ...)])
(contract/internal orig-stx rng out pos-blame neg-blame)))
(lambda args body)
(raise-error
pos-blame
"expected a procedure that accepts ~a arguments, got: ~e"
arity
name)))))]
; [(case-> (cases ...))
; (let ([cases (syntax->list (syntax cases))])
; (with-syntax ([bodies (map build-single-body cases)])
; (syntax
; (case-lambda bodies ...))))]
[(->d funs ...)
(with-syntax ([(doms ...) (all-but-last (syntax->list (syntax (funs ...))))]
[rng (car (last-pair (syntax->list (syntax (funs ...)))))])
(with-syntax ([(ins ...) (generate-temporaries (syntax (doms ...)))])
name))))]
[(case-> (-> funs funss ...) ...)
(with-syntax ([((args bodies) ...) (map build-single-case
(syntax->list (syntax ((funs funss ...) ...))))]
[(arities ...) (map (lambda (x) (- (length (syntax->list x)) 1))
(syntax->list (syntax ((funs funss ...) ...))))])
(syntax
(if (procedure? name)
(lambda (ins ...)
(let ([out (name (contract/internal orig-stx doms ins neg-blame pos-blame) ...)])
(contract/internal orig-stx (rng ins ...) out pos-blame neg-blame)))
(if (and (procedure? name)
(procedure-arity-includes? name arities) ...)
(case-lambda [args bodies] ...)
(raise-error
pos-blame
"expected a procedure, got: ~e" name)))))]
[_
(syntax
(if (a-contract name)
name
(raise-error
pos-blame
"contract failure: ~e" name)))])])))
"expected a procedure that accepts these arities: ~a, got: ~e"
(list arities ...)
name))))]
[(->d funs ...)
(with-syntax ([(doms ...) (all-but-last (syntax->list (syntax (funs ...))))]
[rng (car (last-pair (syntax->list (syntax (funs ...)))))])
(with-syntax ([(ins ...) (generate-temporaries (syntax (doms ...)))])
(syntax
(if (procedure? name)
(lambda (ins ...)
(let ([out (name (contract/internal orig-stx doms ins neg-blame pos-blame) ...)])
(contract/internal orig-stx (rng ins ...) out pos-blame neg-blame)))
(raise-error
pos-blame
"expected a procedure, got: ~e" name)))))]
[_
(syntax
(if (a-contract name)
name
(raise-error
pos-blame
"contract failure: ~e" name)))]))])))

69
collects/tests/framework/spec-test.ss Normal file
View File

@ -0,0 +1,69 @@
(module spec-test mzscheme
(require "test-suite-utils.ss")
(load-framework-automatically #f)
(send-sexp-to-mred '(require (lib "specs.ss" "framework")))
(send-sexp-to-mred '(require (lib "pretty.ss")))
;; test/spec-passed : symbol sexp -> void
;; tests a passing specification
(define (test/spec-passed name expression)
(test name
(lambda (x) (eq? x 'passed))
(lambda ()
(send-sexp-to-mred `(begin ,expression 'passed)))))
;; test/spec-failed : symbol sexp string -> void
;; tests a failing specification with blame assigned to `blame'
(define (test/spec-failed name expression blame)
(test name
(lambda (x)
(and (string? x)
(let ([m (regexp-match "blame ([^:]*):" x)])
(equal? (cadr m) blame))))
(lambda ()
(send-sexp-to-mred `(with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x)))
exn-message])
,expression
'failed/expected-exn-got-normal-termination)))))
(test/spec-passed
'contract-flat1
'(contract not #f 'pos 'neg))
(test/spec-failed
'contract-flat2
'(contract not #t 'pos 'neg)
"pos")
(test/spec-passed
'contract-flat3
'(contract (integer? . -> . integer?) (lambda (x) x) 'pos 'neg))
(test/spec-failed
'contract-flat4
'(contract (integer? . -> . integer?) (lambda (x y) x) 'pos 'neg)
"pos")
(test/spec-failed
'contract-flat5
'(contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
(lambda (x) x)
'pos
'neg)
"pos")
(test/spec-failed
'contract-ho1
'((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) #t)
"neg")
(test/spec-failed
'contract-ho2
'((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) 1)
"pos")
)