>From 495d75812e28729fcd18831c3668eaf1c6890c95 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sun, 22 Apr 2012 19:13:58 +0200
Subject: [PATCH] Do not return early when encountering 'undefined or '* types
 (messes up NOT type checks)

---
 scrutinizer.scm                 |  214 +++++++++++++++++++--------------------
 tests/specialization-test-1.scm |    5 +
 2 files changed, 110 insertions(+), 109 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 3492a88..b7fc363 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1235,115 +1235,111 @@
 	       new))))
     (define (simplify t)
       ;;(dd "simplify/rec: ~s" t)
-      (call/cc 
-       (lambda (return)
-	 (cond ((pair? t)
-		(case (car t)
-		  ((forall)
-		   (let ((typevars (second t)))
-		     (set! typeenv
-		       (append (map (lambda (v)
-				      (let ((v (if (symbol? v) v (first v))))
-					(cons v (gensym v))) )
-				    typevars)
-			       typeenv))
-		     (set! constraints 
-		       (append (filter-map 
-				(lambda (v)
-				  (and (pair? v) v))
-				typevars)
-			       constraints))
-		     (simplify (third t))))
-		  ((or)
- 		   (let* ((ts (map simplify (cdr t)))
- 			  (tslen (length ts)))
- 		     (cond ((= 1 tslen) (car ts))
-			   ((null? ts) '*)
- 			   ((> tslen +maximal-union-type-length+)
- 			    (d "union-type cutoff! (~a): ~s" tslen ts)
- 			    '*)
-			   ((every procedure-type? ts)
-			    (if (any (cut eq? 'procedure <>) ts)
-				'procedure
-				(reduce
-				 (lambda (t pt)
-				   (let* ((name1 (procedure-name t))
-					  (atypes1 (procedure-arguments t))
-					  (rtypes1 (procedure-results t))
-					  (name2 (procedure-name pt))
-					  (atypes2 (procedure-arguments pt))
-					  (rtypes2 (procedure-results pt)))
-				     (append
-				      '(procedure)
-				      (if (and name1 name2 (eq? name1 name2)) (list name1) '())
-				      (list (merge-argument-types atypes1 atypes2))
-				      (merge-result-types rtypes1 rtypes2))))
-				 #f
-				 ts)))
-			   ((lset= eq? '(fixnum float) ts) 'number)
-			   (else
-			    (let* ((ts (append-map
-					(lambda (t)
-					  (let ((t (simplify t)))
-					    (cond ((and (pair? t) (eq? 'or (car t)))
-						   (cdr t))
-						  ((eq? t 'undefined) (return 'undefined))
-						  ((eq? t 'noreturn) '())
-						  (else (list t)))))
-					ts))
-				   (ts2 (let loop ((ts ts) (done '()))
-					  (cond ((null? ts) (reverse done))
-						((eq? '* (car ts)) (return '*))
-						((any (cut type<=? (car ts) <>) (cdr ts))
-						 (loop (cdr ts) done))
-						((any (cut type<=? (car ts) <>) done)
-						 (loop (cdr ts) done))
-						(else (loop (cdr ts) (cons (car ts) done)))))))
-			      (cond ((equal? ts2 (cdr t)) t)
-				    (else
-				     (dd "  or-simplify: ~a" ts2)
-				     (simplify 
-				      `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2)))))))) ))
-		  ((pair) 
-		   (let ((tcar (simplify (second t)))
-			 (tcdr (simplify (third t))))
-		     (if (and (eq? '* tcar) (eq? '* tcdr))
-			 'pair
-			 (let ((t `(pair ,tcar ,tcdr)))
-			   (or (canonicalize-list-of-type t)
-			       t)))))
-		  ((vector-of)
-		   (let ((t2 (simplify (second t))))
-		     (if (eq? t2 '*)
-			 'vector
-			 `(,(car t) ,t2))))
-		  ((vector-of list-of)
-		   (let ((t2 (simplify (second t))))
-		     (if (eq? t2 '*)
-			 'list
-			 `(,(car t) ,t2))))
-		  ((list)
-		   (if (null? (cdr t))
-		       'null
-		       `(list ,@(map simplify (cdr t)))))
-		  ((vector)
-		   `(vector ,@(map simplify (cdr t))))
-		  ((procedure)
-		   (let* ((name (and (named? t) (cadr t)))
-			  (rtypes (if name (cdddr t) (cddr t))))
-		     (append
-		      '(procedure)
-		      (if name (list name) '())
-		      (list (map simplify (if name (third t) (second t))))
-		      (if (eq? '* rtypes)
-			  '*
-			  (map simplify rtypes)))))
-		  (else t)))
-	       ((assq t typeenv) =>
-		(lambda (e)
-		  (set! used (lset-adjoin eq? used t))
-		  (cdr e)))
-	       (else t)))))
+      (cond ((pair? t)
+	     (case (car t)
+	       ((forall)
+		(let ((typevars (second t)))
+		  (set! typeenv
+			(append (map (lambda (v)
+				       (let ((v (if (symbol? v) v (first v))))
+					 (cons v (gensym v))) )
+				     typevars)
+				typeenv))
+		  (set! constraints 
+			(append (filter-map 
+				 (lambda (v)
+				   (and (pair? v) v))
+				 typevars)
+				constraints))
+		  (simplify (third t))))
+	       ((or)
+		(let* ((ts (map simplify (cdr t)))
+		       (tslen (length ts)))
+		  (cond ((= 1 tslen) (car ts))
+			((null? ts) '*)
+			((> tslen +maximal-union-type-length+)
+			 (d "union-type cutoff! (~a): ~s" tslen ts)
+			 '*)
+			((every procedure-type? ts)
+			 (if (any (cut eq? 'procedure <>) ts)
+			     'procedure
+			     (reduce
+			      (lambda (t pt)
+				(let* ((name1 (procedure-name t))
+				       (atypes1 (procedure-arguments t))
+				       (rtypes1 (procedure-results t))
+				       (name2 (procedure-name pt))
+				       (atypes2 (procedure-arguments pt))
+				       (rtypes2 (procedure-results pt)))
+				  (append
+				   '(procedure)
+				   (if (and name1 name2 (eq? name1 name2)) (list name1) '())
+				   (list (merge-argument-types atypes1 atypes2))
+				   (merge-result-types rtypes1 rtypes2))))
+			      #f
+			      ts)))
+			((lset= eq? '(fixnum float) ts) 'number)
+			(else
+			 (let* ((ts (append-map
+				     (lambda (t)
+				       (let ((t (simplify t)))
+					 (cond ((and (pair? t) (eq? 'or (car t)))
+						(cdr t))
+					       ((eq? t 'noreturn) '())
+					       (else (list t)))))
+				     ts))
+				(ts2 (let loop ((ts ts) (done '()))
+				       (cond ((null? ts) (reverse done))
+					     ((any (cut type<=? (car ts) <>) (cdr ts))
+					      (loop (cdr ts) done))
+					     ((any (cut type<=? (car ts) <>) done)
+					      (loop (cdr ts) done))
+					     (else (loop (cdr ts) (cons (car ts) done)))))))
+			   (cond ((equal? ts2 (cdr t)) t)
+				 (else
+				  (dd "	 or-simplify: ~a" ts2)
+				  (simplify 
+				   `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2)))))))) ))
+	       ((pair) 
+		(let ((tcar (simplify (second t)))
+		      (tcdr (simplify (third t))))
+		  (if (and (eq? '* tcar) (eq? '* tcdr))
+		      'pair
+		      (let ((t `(pair ,tcar ,tcdr)))
+			(or (canonicalize-list-of-type t)
+			    t)))))
+	       ((vector-of)
+		(let ((t2 (simplify (second t))))
+		  (if (eq? t2 '*)
+		      'vector
+		      `(,(car t) ,t2))))
+	       ((vector-of list-of)
+		(let ((t2 (simplify (second t))))
+		  (if (eq? t2 '*)
+		      'list
+		      `(,(car t) ,t2))))
+	       ((list)
+		(if (null? (cdr t))
+		    'null
+		    `(list ,@(map simplify (cdr t)))))
+	       ((vector)
+		`(vector ,@(map simplify (cdr t))))
+	       ((procedure)
+		(let* ((name (and (named? t) (cadr t)))
+		       (rtypes (if name (cdddr t) (cddr t))))
+		  (append
+		   '(procedure)
+		   (if name (list name) '())
+		   (list (map simplify (if name (third t) (second t))))
+		   (if (eq? '* rtypes)
+		       '*
+		       (map simplify rtypes)))))
+	       (else t)))
+	    ((assq t typeenv) =>
+	     (lambda (e)
+	       (set! used (lset-adjoin eq? used t))
+	       (cdr e)))
+	    (else t)))
     (let ((t2 (simplify t)))
       (when (pair? typeenv)
 	(set! t2 
diff --git a/tests/specialization-test-1.scm b/tests/specialization-test-1.scm
index 0157420..01bbc8c 100644
--- a/tests/specialization-test-1.scm
+++ b/tests/specialization-test-1.scm
@@ -41,4 +41,9 @@ return n;}
   (set-cdr! x x)
   (assert (not (list? x))))
 
+;(define (some-proc x y) (if (string->number y) (set-cdr! x x) x))
+;(assert (null? (some-proc (list) "invalid number syntax")))
+
+(assert (null? (the (or undefined *) (list))))
+
 )
-- 
1.7.9.1