~ chicken-core (chicken-5) 7cdabbf66c95f8e1e0599b1f6e05791466fc7776
commit 7cdabbf66c95f8e1e0599b1f6e05791466fc7776
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Dec 9 05:24:09 2010 -0500
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Dec 9 05:24:09 2010 -0500
added -picky mode
diff --git a/batch-driver.scm b/batch-driver.scm
index dff1c857..c90f7465 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -183,7 +183,10 @@
(set! all-import-libraries #t))
(set! enable-module-registration (not (memq 'no-module-registration options)))
(when (memq 'lambda-lift options) (set! do-lambda-lifting #t))
- (when (memq 'scrutinize options) (set! do-scrutinize #t))
+ (cond ((memq 'picky options)
+ (set! do-scrutinize 'picky))
+ ((memq 'scrutinize options)
+ (set! do-scrutinize #t)))
(when (memq 't debugging-chicken) (##sys#start-timer))
(when (memq 'b debugging-chicken) (set! time-breakdown #t))
(when (memq 'emit-exports options)
diff --git a/c-platform.scm b/c-platform.scm
index e95b68b4..52001180 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -88,7 +88,7 @@
disable-stack-overflow-checks raw
emit-external-prototypes-first release local inline-global
analyze-only dynamic scrutinize no-argc-checks no-procedure-checks
- no-procedure-checks-for-toplevel-bindings module
+ no-procedure-checks-for-toplevel-bindings module picky
no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax
no-parentheses-synonyms no-symbol-escape r5rs-syntax emit-all-import-libraries
setup-mode unboxing no-module-registration) )
diff --git a/csc.scm b/csc.scm
index 9b0d18b3..6cada4ca 100644
--- a/csc.scm
+++ b/csc.scm
@@ -139,7 +139,7 @@
-no-symbol-escape -no-parentheses-synonyms -r5rs-syntax
-no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax
-emit-all-import-libraries -setup-mode -unboxing -no-elevation -no-module-registration
- -no-procedure-checks-for-usual-bindings -module
+ -no-procedure-checks-for-usual-bindings -module -picky
-no-procedure-checks-for-toplevel-bindings))
(define-constant complex-options
@@ -357,6 +357,7 @@ Usage: #{csc} FILENAME | OPTION ...
-profile-name FILENAME name of the generated profile information
file
-S -scrutinize perform local flow analysis
+ -picky perform more static checks (implies -scrutinize)
-types FILENAME load additional type database
Optimization options:
diff --git a/manual/Using the compiler b/manual/Using the compiler
index b1c22629..62a1fc0f 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -166,6 +166,8 @@ the source text should be read from standard input.
; -output-file FILENAME : Specifies the pathname of the generated C file. Default is {{FILENAME.c}}.
+; -picky : like {{-scrutinize}} but enables more static checks.
+
; -postlude EXPRESSIONS : Add {{EXPRESSIONS}} after all other toplevel expressions in the compiled file. This option may be given multiple times. Processing of this option takes place after processing of {{-epilogue}}.
; -prelude EXPRESSIONS : Add {{EXPRESSIONS}} before all other toplevel expressions in the compiled file. This option may be given multiple times. Processing of this option takes place before processing of {{-prologue}}.
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 2b4fe177..802bfd78 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -532,7 +532,7 @@
(let ((subs (node-subexpressions n))
(params (node-parameters n))
(class (node-class n)) )
- (d "walk: ~a ~a (loc: ~a, dest: ~a, tail: ~a)" class params loc dest tail)
+ (d "walk: ~a ~a (loc: ~a, dest: ~a, tail: ~a, e: ~a)" class params loc dest tail e)
(let ((results
(case class
((quote) (list (constant-result (first params))))
@@ -541,15 +541,16 @@
((##core#global-ref) (global-result (first params) loc))
((##core#variable) (variable-result (first params) e loc))
((if)
- (let ((rt (single "in conditional" (walk (first subs) e loc dest #f) loc))
+ (let ((rt (single "in conditional" (walk (first subs) e loc #f #f) loc))
(c (second subs))
(a (third subs)))
(always-true rt loc n)
(let ((r1 (walk c e loc dest tail))
(r2 (walk a e loc dest tail)))
- ;;XXX this is too heavy, perhaps provide "style" warnings?
;;XXX this could also check for noreturn (same as undefined)
- #;(when (and tail
+ (when (and tail
+ (eq? 'picky do-scrutinize)
+ (<= (length loc) 1)
(if (eq? '##core#undefined (node-class c))
(and (not (eq? '##core#undefined (node-class a)))
(not (self-call? a loc)))
diff --git a/support.scm b/support.scm
index f8b784c9..2c0b425f 100644
--- a/support.scm
+++ b/support.scm
@@ -1275,7 +1275,8 @@ Usage: chicken FILENAME OPTION ...
-accumulate-profile executable emits profiling information in
append mode
-no-lambda-info omit additional procedure-information
- -scrutinize perform local flow analysis
+ -scrutinize perform local flow analysis for static checks
+ -picky perform more static checks (implies -scrutinize)
-types FILENAME load additional type database
Optimization options:
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 61a8c61d..e2e40c19 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -60,7 +60,7 @@ $compile inlining-tests.scm -optimize-level 3
./a.out
echo "======================================== scrutiny tests ..."
-$compile scrutiny-tests.scm -scrutinize -analyze-only -ignore-repository -types ../types.db 2>scrutiny.out
+$compile scrutiny-tests.scm -scrutinize -picky -analyze-only -ignore-repository -types ../types.db 2>scrutiny.out
if test -n "$MSYSTEM"; then
dos2unix scrutiny.out
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index 636779c6..19dfca97 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -39,5 +39,9 @@
(values 42 43)
(fail)))
-(define (foo x)
- (if x 1))
+(define (foo)
+ (define (bar) (if foo 1)) ; should not warn (local)
+ (for-each void '(1 2 3)) ; should not warn (self-call)
+ (if foo 2) ; not in tail position
+ (if bar 3)) ; should warn
+
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index cd3a5bc4..791808da 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -45,4 +45,9 @@ Warning: at toplevel:
Warning: at toplevel:
g89: in procedure call to `g89', expected a value of type `(procedure () *)', but were given a value of type `fixnum'
+Warning: in toplevel procedure `foo':
+ conditional in tail-position has branch with undefined result:
+
+(if bar23 '3 (##core#undefined))
+
Warning: redefinition of standard binding: car
Trap