From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 2 Aug 1995 21:42:14 +0000 (+0000)
Subject: When an expander inserts multiple references to an operand, insert a
X-Git-Tag: 20090517-FFI~6077
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c7d6036fc5bc097cbc0a07c508a0445efe732580;p=mit-scheme.git
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 5e5a785b8..78cda4176 100644
--- 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. |#
;;;; 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)))
(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 fe2a2e2de..1946f08c7 100644
--- 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. |#
;;;; 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)
-
+
(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)
;;;; Hooks and utilities for user defined reductions and expanders