~ chicken-core (chicken-5) cfe84ac3fbf1f6143ea32db6405770b2084462cd
commit cfe84ac3fbf1f6143ea32db6405770b2084462cd
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri May 13 09:18:02 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri May 13 09:18:02 2011 +0200
special-handling of noreturn results in conditional branches; reversed diffing order for scrutiny test
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 61fc0e1a..8c7116f7 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -94,6 +94,7 @@
(define (scrutinize node db complain specialize)
(let ((blist '())
(aliased '())
+ (noreturn #f)
(safe-calls 0))
(define (constant-result lit)
@@ -496,6 +497,14 @@
(sprintf
"~aexpected argument #~a of type `~a', but was given an argument of type `~a'"
(pname) i (car atypes) (car args)))))
+ (when (and (pair? ptype) ;XXX move this into helper procedure
+ (eq? 'procedure (car ptype))
+ (list? ptype)
+ (eq? 'noreturn
+ (if (symbol? (second ptype))
+ (fourth ptype)
+ (third ptype))))
+ (set! noreturn #t))
(let ((r (procedure-result-types ptype values-rest (cdr args))))
;;XXX we should check whether this is a standard- or extended binding
(let* ((pn (procedure-name ptype))
@@ -596,20 +605,33 @@
(c (second subs))
(a (third subs)))
(always-true rt loc n)
- (let ((r1 (walk c e loc dest tail (cons (car tags) flow) #f))
- (r2 (walk a e loc dest tail (cons (cdr tags) flow) #f)))
- (cond ((and (not (eq? '* r1)) (not (eq? '* r2)))
- (when (and (not (any noreturn-type? r1))
- (not (any noreturn-type? r2))
- (not (= (length r1) (length r2))))
- (report
- loc
- (sprintf
- "branches in conditional expression differ in the number of results:~%~%~a"
- (pp-fragment n))))
- (map (lambda (t1 t2) (simplify `(or ,t1 ,t2)))
- r1 r2))
- (else '*)))))
+ (fluid-let ((noreturn #f))
+ (let* ((r1 (walk c e loc dest tail (cons (car tags) flow) #f))
+ (nor1 noreturn))
+ (set! noreturn #f)
+ (let ((r2 (walk a e loc dest tail (cons (cdr tags) flow) #f)))
+ ;; when only one branch is noreturn, add blist entries for
+ ;; all in other branch:
+ (unless (eq? nor1 noreturn)
+ (let ((yestag (if nor1 (cdr tags) (car tags))))
+ (for-each
+ (lambda (ble)
+ (when (eq? (cdar ble) yestag)
+ (d "adding blist entry ~a for returning conditional branch"
+ ble)
+ (add-to-blist (caar ble) (car flow) (cdr ble))))
+ blist)))
+ (cond ((and (not (eq? '* r1)) (not (eq? '* r2)))
+ (when (and (not nor1) (not noreturn)
+ (not (= (length r1) (length r2))))
+ (report
+ loc
+ (sprintf
+ "branches in conditional expression differ in the number of results:~%~%~a"
+ (pp-fragment n))))
+ (map (lambda (t1 t2) (simplify `(or ,t1 ,t2)))
+ r1 r2))
+ (else '*)))))))
((let)
;; before CPS-conversion, `let'-nodes may have multiple bindings
(let loop ((vars params) (body subs) (e2 '()))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 901164d7..d62ef769 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -77,7 +77,7 @@ if test \! -f scrutiny.expected; then
cp scrutiny.out scrutiny.expected
fi
-diff -bu scrutiny.out scrutiny.expected
+diff -bu scrutiny.expected scrutiny.out
$compile scrutiny-tests-2.scm -scrutinize -analyze-only -ignore-repository -types ../types.db
./a.out
Trap