From f24c93b47523a30fb115cb06a09633c8d37f76cd Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 27 Oct 2008 20:02:34 +0000 Subject: [PATCH] Add `warn-unreachable' svn: r12145 original commit: 5db61f199fff5b2a8c0d8595de984184336a5bac --- collects/typed-scheme/utils/tc-utils.ss | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss index 132b2206..def71a74 100644 --- a/collects/typed-scheme/utils/tc-utils.ss +++ b/collects/typed-scheme/utils/tc-utils.ss @@ -30,6 +30,18 @@ (define check-unreachable-code? (make-parameter #f)) +(define warn-unreachable? (make-parameter #t)) + +(define (warn-unreachable e) + (let ([l (current-logger)]) + (when (and (warn-unreachable?) + (log-level? l 'warning) + (printf "~a~n~a~n" (syntax-source-module e) (syntax-source-module (orig-module-stx))) + (eq? (syntax-source-module e) (syntax-source-module (orig-module-stx))) + #;(syntax-source-module e)) + (log-message l 'warning (format "Typed Scheme has detected unreachable code: ~e" (syntax->datum (locate-stx e))) + e)))) + (define (locate-stx stx) (define omodule (orig-module-stx)) (define emodule (expanded-module-stx))