~ chicken-core (chicken-5) f5b02bb9bde320201e4cfdc17aec5650129a5129

commit f5b02bb9bde320201e4cfdc17aec5650129a5129
Merge: 8518c87a 8576f86a
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Dec 2 04:38:53 2010 +0100
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Thu Dec 2 04:38:53 2010 +0100

    resolved conflicts

diff --cc manual/Using the compiler
index c10a7114,f2514a47..0a515c41
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@@ -117,7 -120,9 +117,7 @@@ the source text should be read from sta
  
  ; -keep-shadowed-macros : Do not remove macro definitions with the same name as assigned toplevel variables (the default is to remove the macro definition).
  
- ; -local : Assume toplevel variables defined in the current compilation unit are not externally modified.
 -; -lambda-lift : Enable the optimization known as lambda-lifting.
 -
+ ; -local : Assume toplevel variables defined in the current compilation unit are not externally modified. This gives the compiler more opportunities for inlining. Note that this may result in counter-intuitive and non-standard behaviour: an asssignment to an exported toplevel variable executed in a different compilation unit or in evaluated code will possibly not be seen by code executing in the current compilation unit.
  
  ; -no-argc-checks : disable argument count checks
  
diff --cc scrutinizer.scm
index 01e872d3,6a15f97e..af4626f8
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@@ -530,29 -540,45 +540,43 @@@
  	       ((##core#proc) '(procedure))
  	       ((##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) loc)))
- 		       (always-true rt loc n)
- 		       (let ((r1 (walk (second subs) e loc dest))
- 			     (r2 (walk (third subs) e loc dest)))
- 			 (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 '*)))))
+ 	       ((if)
+ 		(let ((rt (single "in conditional" (walk (first subs) e loc dest #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
+ 			       (if (eq? '##core#undefined (node-class c))
+ 				   (and (not (eq? '##core#undefined (node-class a)))
+ 					(not (self-call? a loc)))
+ 				   (and (eq? '##core#undefined (node-class a))
+ 					(not (self-call? c loc)))))
+ 		      (report
+ 		       loc
+ 		       (sprintf "conditional in tail-position has branch with undefined result:~%~%~a"
+ 			 (pp-fragment n))))
+ 		    (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 '*)))))
  	       ((let)
 -		(let loop ((vars params) (body subs) (e2 '()))
 -		  (if (null? vars)
 -		      (walk (car body) (append e2 e) loc dest tail)
 -		      (let ((t (single 
 -				(sprintf "in `let' binding of `~a'" (real-name (car vars)))
 -				(walk (car body) e loc (car vars) #f) loc)))
 -			(loop (cdr vars) (cdr body) (alist-cons (car vars) t e2))))))
 +		(assert (= 2 (length body))) ;XXX should always be the case
 +		(let ((t (single 
 +			  (sprintf "in `let' binding of `~a'" (real-name (first params)))
- 			  (walk (first body) e loc (first vars)) loc)))
- 		  (walk (second body) (append (alist-cons (car vars) t e2) e) loc dest)))
++			  (walk (first body) e loc (first vars) #f) loc)))
++		  (walk (second body) (append (alist-cons (car vars) t e2) e) loc dest tail)))
  	       ((##core#lambda lambda)
  		(decompose-lambda-list
  		 (first params)