~ chicken-core (chicken-5) df279bda1c3909a65d57053482d325d38becf360
commit df279bda1c3909a65d57053482d325d38becf360
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Jun 20 15:41:13 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Jun 20 15:41:13 2011 +0200
give warning when constant fold fails due to error message
diff --git a/optimizer.scm b/optimizer.scm
index c3c94561..c3f5b6eb 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -187,8 +187,21 @@
(constant-form-eval
var
(cddr subs)
- (lambda (ok form result)
+ (lambda (ok form result msg)
(cond ((not ok)
+ (let ((loc
+ (and (pair? fids)
+ (real-name (car fids)))))
+ (warning
+ (string-append
+ (if loc
+ (string-append "(in " loc ") ")
+ "")
+ "constant-folding expression results in error"
+ (if msg
+ (string-append ": \"" msg "\"")
+ ""))
+ form))
(unless odirty (set! dirty #f))
(set! broken-constant-nodes
(lset-adjoin eq? broken-constant-nodes n1))
diff --git a/support.scm b/support.scm
index 1b7bd317..1efe0813 100644
--- a/support.scm
+++ b/support.scm
@@ -1307,14 +1307,16 @@
(form (cons op (map (lambda (arg) `(quote ,arg)) args))))
(handle-exceptions ex
(begin
- (debugging 'o "folding constant expression failed" form)
- (k #f form #f))
+ (k #f form #f (get-condition-property ex 'exn 'message)))
;; op must have toplevel binding, result must be single-valued
(let ((proc (##sys#slot op 0)))
(if (procedure? proc)
- (let ((result (apply proc args)))
- (debugging 'o "folded constant expression" form)
- (k #t form result))
+ (let ((results (receive (apply proc args))))
+ (cond ((= 1 (length results))
+ (debugging 'o "folded constant expression" form)
+ (k #t form (car results) #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))))))
Trap