When an expander inserts multiple references to an operand, insert a

LET so that the operand is only bound once.

diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm
index 5e5a785b8b3591ed576fd7fbbc3d5d13bd78d2ea..78cda41768ae692ac14ab67c4a34a251e5c6bbab 100644 (file)
--- a/v7/src/sf/usiexp.scm
+++ b/v7/src/sf/usiexp.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: usiexp.scm,v 4.34 1995/04/29 13:08:29 adams Exp $
+$Id: usiexp.scm,v 4.35 1995/08/02 21:42:07 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -40,14 +40,25 @@ MIT in each case. |#
 \f
 ;;;; Fixed-arity arithmetic primitives
 
-
 (define (make-combination expression block primitive operands)
-  (combination/make (and expression
-                        (object/scode expression))
+  (combination/make (and expression (object/scode expression))
                    block
                    (constant/make false primitive)
                    operands))
 
+(define (make-operand-binding expression block operand make-body)
+  (combination/make (and expression (object/scode expression))
+                   block
+                   (let ((block (block/make block #t '()))
+                         (name (string->uninterned-symbol "operand")))
+                     (let ((variable (variable/make&bind! block name)))
+                       (procedure/make
+                        #f
+                        block lambda-tag:let (list variable) '() #f
+                        (make-body block
+                                   (reference/make #f block variable)))))
+                   (list operand)))
+
 (define (constant-eq? expression constant)
   (and (constant? expression)
        (eq? (constant/value expression) constant)))
@@ -160,8 +171,8 @@ MIT in each case. |#
 
 (define (fix:<=-expansion expr operands if-expanded if-not-expanded block)
   (if (and (pair? operands)
-               (pair? (cdr operands))
-               (null? (cddr operands)))
+          (pair? (cdr operands))
+          (null? (cddr operands)))
       (if-expanded
        (make-combination
        expr
@@ -231,18 +242,10 @@ MIT in each case. |#
 (define (expt-expansion expr operands if-expanded if-not-expanded block)
   (let ((make-binder
         (lambda (make-body)
-          (if-expanded
-           (combination/make
-            (and expr (object/scode expr))
-            block
-            (let ((block (block/make block #t '()))
-                  (name (string->uninterned-symbol "operand")))
-              (let ((variable (variable/make&bind! block name)))
-                (procedure/make
-                 #f
-                 block lambda-tag:let (list variable) '() #f
-                 (make-body block (reference/make false block variable)))))
-            (list (car operands)))))))
+          (make-operand-binding expr
+                                block
+                                (car operands)
+                                make-body))))
     (cond ((not (and (pair? operands)
                     (pair? (cdr operands))
                     (null? (cddr operands))))
@@ -481,10 +484,12 @@ MIT in each case. |#
   (if (and (pair? operands)
           (null? (cdr operands)))
       (if-expanded
-       (make-disjunction
-       expr
-       (make-type-test false block (ucode-type fixnum) (car operands))
-       (make-type-test false block (ucode-type big-fixnum) (car operands))))
+       (make-operand-binding expr block (car operands)
+        (lambda (block operand)
+          (make-disjunction
+           expr
+           (make-type-test #f block (ucode-type fixnum) operand)
+           (make-type-test #f block (ucode-type big-fixnum) operand)))))
       (if-not-expanded)))
 
 (define (exact-rational?-expansion expr operands if-expanded if-not-expanded
@@ -492,36 +497,41 @@ MIT in each case. |#
   (if (and (pair? operands)
           (null? (cdr operands)))
       (if-expanded
-       (make-disjunction
-       expr
-       (make-type-test false block (ucode-type fixnum) (car operands))
-       (make-type-test false block (ucode-type big-fixnum) (car operands))
-       (make-type-test false block (ucode-type ratnum) (car operands))))
+       (make-operand-binding expr block (car operands)
+        (lambda (block operand)
+          (make-disjunction
+           expr
+           (make-type-test #f block (ucode-type fixnum) operand)
+           (make-type-test #f block (ucode-type big-fixnum) operand)
+           (make-type-test #f block (ucode-type ratnum) operand)))))
       (if-not-expanded)))
 
 (define (complex?-expansion expr operands if-expanded if-not-expanded block)
   (if (and (pair? operands)
           (null? (cdr operands)))
       (if-expanded
-       (make-disjunction
-       expr
-       (make-type-test false block (ucode-type fixnum) (car operands))
-       (make-type-test false block (ucode-type big-fixnum) (car operands))
-       (make-type-test false block (ucode-type ratnum) (car operands))
-       (make-type-test false block (ucode-type big-flonum) (car operands))
-       (make-type-test false block (ucode-type recnum) (car operands))))
+       (make-operand-binding expr block (car operands)
+        (lambda (block operand)
+          (make-disjunction
+           expr
+           (make-type-test #f block (ucode-type fixnum) operand)
+           (make-type-test #f block (ucode-type big-fixnum) operand)
+           (make-type-test #f block (ucode-type ratnum) operand)
+           (make-type-test #f block (ucode-type big-flonum) operand)
+           (make-type-test #f block (ucode-type recnum) operand)))))
       (if-not-expanded)))
 
 (define (symbol?-expansion expr operands if-expanded if-not-expanded block)
   (if (and (pair? operands)
           (null? (cdr operands)))
       (if-expanded
-       (make-disjunction
-       expr
-       (make-type-test false block (ucode-type interned-symbol)
-                       (car operands))
-       (make-type-test false block (ucode-type uninterned-symbol)
-                       (car operands))))
+       (make-operand-binding expr block (car operands)
+        (lambda (block operand)
+          (make-disjunction
+           expr
+           (make-type-test #f block (ucode-type interned-symbol) operand)
+           (make-type-test #f block (ucode-type uninterned-symbol)
+                           operand)))))
       (if-not-expanded)))
 \f
 (define (make-disjunction expr . clauses)
@@ -530,7 +540,7 @@ MIT in each case. |#
        (car clauses)
        (disjunction/make (and expr (object/scode expr))
                          (car clauses) (loop (cdr clauses))))))
-      
+
 (define (make-type-test expr block type operand)
   (make-combination expr block
                    (ucode-primitive object-type?)

diff --git a/v8/src/sf/usiexp.scm b/v8/src/sf/usiexp.scm
index fe2a2e2de94f159b3ce4f9e609b70ec7ee2124a4..1946f08c79b3f27c00ccc013604c382c41ff2d90 100644 (file)
--- a/v8/src/sf/usiexp.scm
+++ b/v8/src/sf/usiexp.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: usiexp.scm,v 1.3 1995/08/02 19:02:17 adams Exp $
+$Id: usiexp.scm,v 1.4 1995/08/02 21:42:14 cph Exp $
 
 Copyright (c) 1988-1995 Massachusetts Institute of Technology
 
@@ -47,12 +47,24 @@ MIT in each case. |#
   ;;;; Fixed-arity arithmetic primitives
 
   (define (make-combination expression block primitive operands)
-    (combination/make (and expression
-                          (object/scode expression))
+    (combination/make (and expression (object/scode expression))
                      block
                      (constant/make false primitive)
                      operands))
 
+  (define (make-operand-binding expression block operand make-body)
+    (combination/make (and expression (object/scode expression))
+                     block
+                     (let ((block (block/make block #t '()))
+                           (name (string->uninterned-symbol "operand")))
+                       (let ((variable (variable/make&bind! block name)))
+                         (procedure/make
+                          #f
+                          block lambda-tag:let (list variable) '() #f
+                          (make-body block
+                                     (reference/make #f block variable)))))
+                     (list operand)))
+
   (define (constant-eq? expression constant)
     (and (constant? expression)
         (eq? (constant/value expression) constant)))
@@ -227,7 +239,8 @@ MIT in each case. |#
             ((constant-eq? y 1)
              (make-combination expr block (ucode-primitive 1+) (list x)))
             (else
-             (make-combination expr block (ucode-primitive &+) (list x y)))))))
+             (make-combination expr block (ucode-primitive &+)
+                               (list x y)))))))
 
   (define *-expansion
     (right-accumulation 
@@ -239,18 +252,10 @@ MIT in each case. |#
   (define (expt-expansion expr operands if-expanded if-not-expanded block)
     (let ((make-binder
           (lambda (make-body)
-            (if-expanded
-             (combination/make
-              (and expr (object/scode expr))
-              block
-              (let ((block (block/make block #t '()))
-                    (name (string->uninterned-symbol "operand")))
-                (let ((variable (variable/make&bind! block name)))
-                  (procedure/make
-                   #f
-                   block lambda-tag:let (list variable) '() #f
-                   (make-body block (reference/make false block variable)))))
-              (list (car operands)))))))
+            (make-operand-binding expr
+                                  block
+                                  (car operands)
+                                  make-body))))
       (cond ((not (and (pair? operands)
                       (pair? (cdr operands))
                       (null? (cddr operands))))
@@ -357,7 +362,7 @@ MIT in each case. |#
                          block
                          (ucode-primitive cons)
                          (list (car rest)
-                               (cons*-expansion-loop false block (cdr rest))))))
+                               (cons*-expansion-loop #f block (cdr rest))))))
 
   (define (list-expansion expr operands if-expanded if-not-expanded block)
     (if (< (length operands) 9)
@@ -369,7 +374,7 @@ MIT in each case. |#
        (constant/make (and expr (object/scode expr)) '())
        (make-combination expr block (ucode-primitive cons)
                          (list (car rest)
-                               (list-expansion-loop false block (cdr rest))))))
+                               (list-expansion-loop #f block (cdr rest))))))
 
   (define (values-expansion expr operands if-expanded if-not-expanded block)
     if-not-expanded
@@ -466,7 +471,8 @@ MIT in each case. |#
 \f
   ;;;; Miscellaneous
 
-  (define (make-string-expansion expr operands if-expanded if-not-expanded block)
+  (define (make-string-expansion expr operands if-expanded if-not-expanded
+                                block)
     (if (and (pair? operands)
             (null? (cdr operands)))
        (if-expanded
@@ -486,11 +492,15 @@ MIT in each case. |#
       (if (and (pair? operands)
               (null? (cdr operands)))
          (if-expanded
-          (make-disjunction
-           expr
-           (map (lambda (type)
-                  (make-type-test false block type (car operands)))
-                get-the-types)))
+          (if (null? (cdr get-the-types))
+              (make-type-test #f block (car get-the-types) (car operands))
+              (make-operand-binding expr block (car operands)
+                (lambda (block operand)
+                  (make-disjunction
+                   expr
+                   (map (lambda (type)
+                          (make-type-test #f block type operand))
+                        get-the-types))))))
          (if-not-expanded))))
 
   (define char?-expansion
@@ -537,7 +547,7 @@ MIT in each case. |#
      (list (cross-sf/ucode-type 'interned-symbol)
           (cross-sf/ucode-type 'uninterned-symbol))))
 
-  (define (make-disjunction expr  clauses)
+  (define (make-disjunction expr clauses)
     (let loop ((clauses clauses))
       (if (null? (cdr clauses))
          (car clauses)
@@ -653,15 +663,16 @@ MIT in each case. |#
       (weak-pair?         . ,weak-pair?-expansion)
       (with-values        . ,call-with-values-expansion)
       (zero?              . ,zero?-expansion)
-     ))
+      ))
 
   usual-integrations/expansion-alist)
-\f
+
 (define usual-integrations/expansion-alist)
 
 (define (usual-integrations/initialize-expanders!)
   (set! usual-integrations/expansion-alist
-       (usual-integrations/make-expansion-alist)))
+       (usual-integrations/make-expansion-alist))
+  unspecific)
 \f
 ;;;;  Hooks and utilities for user defined reductions and expanders