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

DMdA Contract bug fix: In yet another place, make sure that the

Browse Source 
enforcer calls `contract-violation' in tail position.

svn: r18095
This commit is contained in:
Mike Sperber 2010-02-16 07:51:02 +00:00
parent 30e8c7d039
commit d64254f49f
1 changed files with 37 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
collects/deinprogramm/contract/contract.ss
View File

@ -228,42 +228,43 @@
((not (procedure? proc)) ((not (procedure? proc))
(contract-violation proc self #f #f)) (contract-violation proc self #f #f))
((not (procedure-arity-includes? proc arg-count)) ; #### variable arity ((not (procedure-arity-includes? proc arg-count)) ; #### variable arity
(contract-violation proc self "falsche Anzahl von Parametern" #f))) (contract-violation proc self "falsche Anzahl von Parametern" #f))
(attach-name (else
(object-name proc) (attach-name
(procedure-reduce-arity (object-name proc)
(lambda args (procedure-reduce-arity
(call-with-immediate-continuation-mark (lambda args
contract-key (call-with-immediate-continuation-mark
(lambda (maybe) contract-key
(if (not (= (length args) arg-count)) (lambda (maybe)
(begin (if (not (= (length args) arg-count))
(contract-violation proc self "falsche Anzahl von Argumenten" #f) (begin
(apply-contract return-contract (apply proc args))) (contract-violation proc self "falsche Anzahl von Argumenten" #f)
(let* ((old-violation-proc (contract-violation-proc)) (apply-contract return-contract (apply proc args)))
(arg-violation? #f) (let* ((old-violation-proc (contract-violation-proc))
(args (arg-violation? #f)
(call-with-contract-violation-proc (args
(lambda (obj contract message blame) (call-with-contract-violation-proc
(set! arg-violation? #t) (lambda (obj contract message blame)
(old-violation-proc obj contract message blame)) (set! arg-violation? #t)
(lambda () (old-violation-proc obj contract message blame))
(map apply-contract arg-contracts args))))) (lambda ()
(if (eq? maybe return-contract) (map apply-contract arg-contracts args)))))
(apply proc args) (if (eq? maybe return-contract)
(let ((retval (apply proc args)
(with-continuation-mark (let ((retval
contract-key return-contract (with-continuation-mark
(apply proc args)))) contract-key return-contract
(if arg-violation? (apply proc args))))
retval (if arg-violation?
(call-with-contract-violation-proc retval
(lambda (obj contract message _) (call-with-contract-violation-proc
;; blame the procedure (lambda (obj contract message _)
(old-violation-proc obj contract message blame-syntax)) ;; blame the procedure
(lambda () (old-violation-proc obj contract message blame-syntax))
(apply-contract return-contract retval))))))))))) (lambda ()
(procedure-arity proc))))) (apply-contract return-contract retval)))))))))))
(procedure-arity proc)))))))
syntax syntax
(delay (delay
(apply lift->arbitrary arbitrary-procedure return-contract arg-contracts))))) (apply lift->arbitrary arbitrary-procedure return-contract arg-contracts)))))