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