~ chicken-core (chicken-5) 11dd2caa33f9cf20eca006c598bd8f378ebf339c

commit 11dd2caa33f9cf20eca006c598bd8f378ebf339c
Author:     megane <meganeka@gmail.com>
AuthorDate: Thu Feb 28 07:33:06 2019 +0200
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Sun Mar 31 16:10:02 2019 +0200

    * support.scm (constant-form-eval): Simplify logic
    
    Change the code so 'k' is only called from tail position.
    
    This simplifies the handling of case where the apply call causes an
    exception. In the old code, this would cause a call to 'k' from a
    non-tail position with ok value of #f. This would be handled in the
    optimizer by returning the original n1. This is returned to
    constant-form-eval as the value for the results variable. This causes
    the first cond clause to fire (the one with the TODO comment), and 'k'
    is called again.
    
    Also, remove the form and msg arguments to 'k' as those are not used.
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/optimizer.scm b/optimizer.scm
index ad13240e..6318fbf2 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -215,7 +215,7 @@
 			  (constant-form-eval
 			   var
 			   (cddr subs)
-			   (lambda (ok form result msg)
+			   (lambda (ok result)
 			     (cond ((not ok)
 				    (unless odirty (set! dirty #f))
 				    (set! broken-constant-nodes
diff --git a/support.scm b/support.scm
index 48616a8e..c802880e 100644
--- a/support.scm
+++ b/support.scm
@@ -1493,18 +1493,14 @@
     ;; op must have toplevel binding, result must be single-valued
     (let ((proc (##sys#slot op 0)))
       (if (procedure? proc)
-	  (let ((results (handle-exceptions ex
-			     (k #f form #f
-				(get-condition-property ex 'exn 'message))
-			   (receive (apply proc args)))))
-	    (cond ((node? results) ; TODO: This should not happen
-		   (k #f form #f #f))
+	  (let ((results (handle-exceptions ex ex (receive (apply proc args)))))
+	    (cond ((condition? results) (k #f #f))
 		  ((and (= 1 (length results))
 			(encodeable-literal? (car results)))
 		   (debugging 'o "folded constant expression" form)
-		   (k #t form (car results) #f))
+		   (k #t (car results)))
 		  ((= 1 (length results)) ; not encodeable; don't fold
-		   (k #f form #f #f))
+		   (k #f #f))
 		  (else
 		   (bomb "attempt to constant-fold call to procedure that has multiple results" form))))
 	  (bomb "attempt to constant-fold call to non-procedure" form)))))