commit 2c6ca370285cbcb37b1ad73bc6fa91ab22d62f5c parent 024f90b9715012e07c294fd3a78121700db1654d Author: Alex Knauth <alexander@knauth.org> Date: Tue, 26 Jan 2016 22:06:49 -0500 Merge pull request #1 from stamourv/master Add contract profiling instrumentation. Diffstat:
| M | kw-utils/kw-hash/contract.rkt | | | 45 | ++++++++++++++++++++++++--------------------- |
1 file changed, 24 insertions(+), 21 deletions(-)
diff --git a/kw-utils/kw-hash/contract.rkt b/kw-utils/kw-hash/contract.rkt @@ -67,27 +67,30 @@ (chaperone-procedure f (keyword-lambda (kws kw-args . args) - (check-length blame f (length args) - (if rest-wrapper - (arity-at-least n) - n)) - (define args* - (map app arg-wrappers (take args n))) - (define rest* - (and rest-wrapper (rest-wrapper (drop args n)))) - (define args+rest* - (if rest-wrapper - (append args* rest*) - args*)) - (define kw-hash* - (kws-wrapper (keyword-app-make-kw-hash kws kw-args))) - ;; kw-args* has to be in the same order as kw-args - (define kw-args* - (map-hash-ref kw-hash* kws)) - (if (null? kw-args*) - ;; if no keywords were passed in, don't include them - (apply values args+rest*) - (apply values kw-args* args+rest*)))))) + (with-continuation-mark + contract-continuation-mark-key blame + (let () + (check-length blame f (length args) + (if rest-wrapper + (arity-at-least n) + n)) + (define args* + (map app arg-wrappers (take args n))) + (define rest* + (and rest-wrapper (rest-wrapper (drop args n)))) + (define args+rest* + (if rest-wrapper + (append args* rest*) + args*)) + (define kw-hash* + (kws-wrapper (keyword-app-make-kw-hash kws kw-args))) + ;; kw-args* has to be in the same order as kw-args + (define kw-args* + (map-hash-ref kw-hash* kws)) + (if (null? kw-args*) + ;; if no keywords were passed in, don't include them + (apply values args+rest*) + (apply values kw-args* args+rest*)))))))) ;; check-procedure : Blame Any -> Void (define (check-procedure blame f)