~ chicken-core (chicken-5) cf5f48407668414995d908177f797002e3389e19

commit cf5f48407668414995d908177f797002e3389e19
Author:     megane <meganeka@gmail.com>
AuthorDate: Mon May 14 21:59:05 2018 +1200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Tue May 15 10:32:38 2018 +0200

    Fix error during compiler-typecase trail restore
    
    This fixes an error that can occur when a typecase clause fails to match
    and the subsequent trail restoration fails due to an incorrect
    environment being passed to `trail-restore'. This argument should be the
    one used for matching, not the original environment containing just the
    source expression's types.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>
    Signed-off-by: felix <felix@call-with-current-continuation.org>

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 4869cc6b..ece07ed3 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -850,27 +850,26 @@
 		 ((##core#typecase)
 		  (let* ((ts (walk (first subs) e loc #f #f flow ctags))
 			 (trail0 trail)
-			 (typeenv (type-typeenv (car ts))))
+			 (typeenv0 (type-typeenv (car ts))))
 		    ;; first exp is always a variable so ts must be of length 1
 		    (let loop ((types (cdr params)) (subs (cdr subs)))
-		      (cond ((null? types)
-			     (quit-compiling
-			      "~a~ano clause applies in `compiler-typecase' for expression of type `~a':~a"
-			      (location-name loc)
-			      (node-source-prefix n)
-			      (type-name (car ts))
-			      (string-intersperse
-			       (map (lambda (t) (sprintf "\n    ~a" (type-name t)))
-				    (cdr params)) "")))
-			    ((match-types (car types) (car ts) 
-					  (append (type-typeenv (car types)) typeenv)
-					  #t)
-			     ;; drops exp
-			     (mutate-node! n (car subs))
-			     (walk n e loc dest tail flow ctags))
-			    (else
-			     (trail-restore trail0 typeenv)
-			     (loop (cdr types) (cdr subs)))))))
+		      (if (null? types)
+			  (quit-compiling
+			   "~a~ano clause applies in `compiler-typecase' for expression of type `~a':~a"
+			   (location-name loc)
+			   (node-source-prefix n)
+			   (type-name (car ts))
+			   (string-intersperse
+			    (map (lambda (t) (sprintf "\n    ~a" (type-name t)))
+				 (cdr params)) ""))
+			  (let ((typeenv (append (type-typeenv (car types)) typeenv0)))
+			    (if (match-types (car types) (car ts) typeenv #t)
+				(begin ; drops exp
+				  (mutate-node! n (car subs))
+				  (walk n e loc dest tail flow ctags))
+				(begin
+				  (trail-restore trail0 typeenv)
+				  (loop (cdr types) (cdr subs)))))))))
 		 ((##core#switch ##core#cond)
 		  (bomb "scrutinize: unexpected node class" class))
 		 (else
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index ef4e0d96..96757b7e 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -311,3 +311,8 @@
   (define (append-result-type-nowarn2) (add1 (list-ref l2 1))))
 (let ((l3 (append (the (list-of fixnum) '(1 2)) '(x y))))
   (define (append-result-type-nowarn3) (add1 (list-ref l3 1))))
+
+;; Check the trail is restored from the combined typeenv
+(compiler-typecase (list 2 'a)
+  ((forall (x) (list x x)) 1)
+  (else #t))