From 467f19ed2b14c5f3a7e246d45dcb8869d5648a9f Mon Sep 17 00:00:00 2001
From: Jacob Katzenelson <edu/mit/csail/zurich/jacob>
Date: Mon, 30 Aug 1993 22:16:55 +0000
Subject: [PATCH] (CPH:) Add expansion of expt for small exact exponents.

---
 v7/src/sf/usiexp.scm | 57 +++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 56 insertions(+), 1 deletion(-)

diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm
index 8a3acdc53..44c57be2e 100644
--- a/v7/src/sf/usiexp.scm
+++ b/v7/src/sf/usiexp.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: usiexp.scm,v 4.15 1993/08/03 03:09:53 gjr Exp $
+$Id: usiexp.scm,v 4.16 1993/08/30 22:16:55 jacob Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -225,6 +225,59 @@ MIT in each case. |#
     (lambda (expr x y)
       (make-combination expr (ucode-primitive &*) (list x y)))))
 
+(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))
+	     (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 (reference/make false block variable)))))
+	     (list (car operands)))))))
+    (cond ((not (and (pair? operands)
+		     (pair? (cdr operands))
+		     (null? (cddr operands))))
+	   (if-not-expanded))
+	  ;;((constant-eq? (cadr operands) 0)
+	  ;; (if-expanded (constant/make (and expr (object/scode expr)) 1)))
+	  ((constant-eq? (cadr operands) 1)
+	   (if-expanded (car operands)))
+	  ((constant-eq? (cadr operands) 2)
+	   (make-binder
+	    (lambda (operand)
+	      (make-combination #f
+				(ucode-primitive &*)
+				(list operand operand)))))
+	  ((constant-eq? (cadr operands) 3)
+	   (make-binder
+	    (lambda (operand)
+	      (make-combination
+	       #f
+	       (ucode-primitive &*)
+	       (list operand
+		     (make-combination #f
+				       (ucode-primitive &*)
+				       (list operand operand)))))))
+	  ((constant-eq? (cadr operands) 4)
+	   (make-binder
+	    (lambda (operand)
+	      (make-combination
+	       #f
+	       (ucode-primitive &*)
+	       (list (make-combination #f
+				       (ucode-primitive &*)
+				       (list operand operand))
+		     (make-combination #f
+				       (ucode-primitive &*)
+				       (list operand operand)))))))
+	  (else
+	   (if-not-expanded)))))
+
 (define (right-accumulation-inverse identity inverse-expansion make-binary)
   (lambda (expr operands if-expanded if-not-expanded block)
     (let ((expand
@@ -522,6 +575,7 @@ MIT in each case. |#
     eighth
     exact-integer?
     exact-rational?
+    expt
     fifth
     fix:<=
     fix:=
@@ -602,6 +656,7 @@ MIT in each case. |#
    eighth-expansion
    exact-integer?-expansion
    exact-rational?-expansion
+   expt-expansion
    fifth-expansion
    fix:<=-expansion
    fix:=-expansion
-- 
2.25.1