Don't constant-fold an application if it generates an error.

Also fix overlong lines and pages in object.scm.

diff --git a/src/compiler/fgopt/folcon.scm b/src/compiler/fgopt/folcon.scm
index ee2410dc9ff9bbcc0337850bf78443400680c223..86cca53b023cde6e9e101191161e7902740c6503 100644 (file)
--- a/src/compiler/fgopt/folcon.scm
+++ b/src/compiler/fgopt/folcon.scm
@@ -174,9 +174,13 @@ USA.
                      (error "fold-combination: Wrong number of arguments"
                             op (length operands))
                      false))
-               (let ((constant
-                      (make-constant
-                       (apply op (map rvalue-constant-value operands)))))
+               (let ((value
+                      (let ((operands (map rvalue-constant-value operands)))
+                        (ignore-errors
+                         (lambda ()
+                           (apply op operands))))))
+                 (and (not (condition? value))
+                      (let ((constant (make-constant value)))
                  (combination/constant! combination constant)
                  (for-each (lambda (value)
                              (if (uni-continuation? value)
@@ -184,7 +188,7 @@ USA.
                                   (uni-continuation/parameter value)
                                   constant)))
                            (rvalue-values continuation))
-                 true))))))
+                        true))))))))
 \f
 (define (maybe-fold-lvalue! lvalue constant)
   (lvalue-connect!:rvalue lvalue constant)

diff --git a/src/sf/object.scm b/src/sf/object.scm
index 39e56cd95e1ff7ec400d49f32ae70a1865e634cf..0924a612373327b7e347fc3c038e81ba1ca2071c 100644 (file)
--- a/src/sf/object.scm
+++ b/src/sf/object.scm
@@ -178,7 +178,7 @@ USA.
   value)
 
 (define-guarantee delayed-integration "delayed integration")
-
+\f
 ;;; VARIABLE
 ;; Done specially so we can tweak the print method.
 ;; This makes debugging an awful lot easier.
@@ -200,20 +200,20 @@ USA.
 (define-guarantee variable "variable")
 
 ;;; Expressions
-(define-simple-type access          #f                 (block environment name))
-(define-simple-type assignment      #f                 (block variable value))
-(define-simple-type combination     combination/%make  (block operator operands))
-(define-simple-type conditional     #f                 (predicate consequent alternative))
-(define-simple-type constant        #f                 (value))
-(define-simple-type declaration     #f                 (declarations expression))
-(define-simple-type delay           #f                 (expression))
-(define-simple-type disjunction     #f                 (predicate alternative))
-(define-simple-type open-block      #f                 (block variables values actions))
-(define-simple-type procedure       #f                 (block name required optional rest body))
-(define-simple-type quotation       #f                 (block expression))
-(define-simple-type sequence        sequence/%make     (actions))
-(define-simple-type the-environment #f                 (block))
-
+(define-simple-type access #f (block environment name))
+(define-simple-type assignment #f (block variable value))
+(define-simple-type combination combination/%make (block operator operands))
+(define-simple-type conditional #f (predicate consequent alternative))
+(define-simple-type constant #f (value))
+(define-simple-type declaration #f (declarations expression))
+(define-simple-type delay #f (expression))
+(define-simple-type disjunction #f (predicate alternative))
+(define-simple-type open-block #f (block variables values actions))
+(define-simple-type procedure #f (block name required optional rest body))
+(define-simple-type quotation #f (block expression))
+(define-simple-type sequence sequence/%make (actions))
+(define-simple-type the-environment #f (block))
+\f
 ;;; Helpers for expressions
 
 ;; The primitive predicates that only return #T or #F.
@@ -271,7 +271,7 @@ USA.
                      (procedure-arity-valid?
                       operator-value
                       (length (combination/operands expression)))))))))
-
+\f
 ;; These primitives have no side effects.  We consider primitives
 ;; that check their arguments *have* a side effect. (Conservative)
 (define effect-free-primitives
@@ -331,9 +331,10 @@ USA.
 
 (define (global-ref? object)
   (and (scode-access? object)
-       (expression/constant-eq? (access/environment object) system-global-environment)
+       (expression/constant-eq? (access/environment object)
+                               system-global-environment)
        (access/name object)))
-
+\f
 ;;; Constructors that need to do work.
 
 ;; When constucting a combination, we may discover that we
@@ -437,7 +438,7 @@ USA.
         zero-fixnum?
         zero?
         )))
-
+\f
 (define (foldable-combination? operator operands)
   (and (constant? operator)
        (let ((operator-value (constant/value operator)))
@@ -445,7 +446,13 @@ USA.
               (procedure-arity-valid? operator-value (length operands))
               (memq operator-value combination/constant-folding-operators)))
           ;; Check that the arguments are constant.
-       (every constant? operands)))
+       (every constant? operands)
+       (not (condition?
+       (let ((operator (constant/value operator))
+            (operands (map constant/value operands)))
+              (ignore-errors
+               (lambda ()
+                 (apply operator operands))))))))
 
 ;; An operator is reducible if we can safely rewrite its argument list.
 (define (reducible-operator? operator)
@@ -506,19 +513,21 @@ USA.
                     (and expression (object/scode expression))
                     (append other-operands (list result-body))))))))
         (else
-         (combination/%make (and expression (object/scode expression)) block operator operands))))
-
+         (combination/%make (and expression (object/scode expression))
+                           block operator operands))))
+\f
 (define (combination/fold-constant expression operator operands)
   (let ((result (apply operator operands)))
-  (if (not (eq? sf:enable-constant-folding? #t))
-      (with-notification
-       (lambda (port)
-         (display "Folding (" port)
-         (display operator port)
-         (for-each (lambda (operand) (display " " port) (write operand port)) operands)
-         (display ") => " port)
-         (write result port))))
-  (constant/make (and expression (object/scode expression)) result)))
+    (if (not (eq? sf:enable-constant-folding? #t))
+       (with-notification
+        (lambda (port)
+          (display "Folding (" port)
+          (display operator port)
+          (for-each (lambda (operand) (display " " port) (write operand port))
+                    operands)
+          (display ") => " port)
+          (write result port))))
+    (constant/make (and expression (object/scode expression)) result)))
 
 (define-integrable (partition-operands operator operands)
   (let ((free-in-body (expression/free-variables (procedure/body operator))))
@@ -533,7 +542,8 @@ USA.
                  (values (reverse required-parameters) ; preserve order
                          (reverse referenced-operands)
                          (if (or (null? operands)
-                                 (variable/integrated (procedure/rest operator)))
+                                 (variable/integrated
+                                 (procedure/rest operator)))
                              unreferenced-operands
                              (append operands unreferenced-operands)))
                  (error "Argument mismatch" operands)))
@@ -561,7 +571,7 @@ USA.
                             referenced-operands
                             (cons this-operand
                                   unreferenced-operands))))))))))
-
+\f
 ;;; Sequence
 
 ;;  Ensure that sequences are always flat.
@@ -569,7 +579,8 @@ USA.
   (define (sequence/collect-actions collected actions)
     (fold-left (lambda (reversed action)
                  (if (scode-sequence? action)
-                     (sequence/collect-actions reversed (sequence/actions action))
+                     (sequence/collect-actions reversed
+                                              (sequence/actions action))
                      (cons action reversed)))
                collected
                actions))