From 0c7f22e651aaf421710e985c39e19566bf9d6e24 Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Fri, 8 Sep 1995 03:09:09 +0000
Subject: [PATCH] Added expansion for global LIST-REF.

---
 v8/src/compiler/midend/earlyrew.scm | 52 +++++++++++++++++++----------
 1 file changed, 35 insertions(+), 17 deletions(-)

diff --git a/v8/src/compiler/midend/earlyrew.scm b/v8/src/compiler/midend/earlyrew.scm
index b414efbad..40a94cd85 100644
--- a/v8/src/compiler/midend/earlyrew.scm
+++ b/v8/src/compiler/midend/earlyrew.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: earlyrew.scm,v 1.15 1995/09/05 18:56:00 adams Exp $
+$Id: earlyrew.scm,v 1.16 1995/09/08 03:09:09 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -496,28 +496,32 @@ MIT in each case. |#
 	    (else
 	     (default))))))
 
-(define-rewrite/early 'GENERAL-CAR-CDR
-  (let ((prim-general-car-cdr (make-primitive-procedure 'GENERAL-CAR-CDR))
-        (prim-car             (make-primitive-procedure 'CAR))
+
+(define earlyrew/general-car-cdr
+  (let ((prim-car             (make-primitive-procedure 'CAR))
         (prim-cdr             (make-primitive-procedure 'CDR)))
+    (lambda (term pattern equivalent)
+      (let walk-bits ((num  pattern) (text term))
+	(if (= num 1)
+	    text
+	    (walk-bits (quotient num 2)
+		       (equivalent
+			`(CALL (QUOTE ,(if (odd? num)
+					   prim-car
+					   prim-cdr))
+			       (QUOTE #f)
+			       ,text))))))))
+
+(define-rewrite/early 'GENERAL-CAR-CDR
+  (let ((prim-general-car-cdr (make-primitive-procedure 'GENERAL-CAR-CDR)))
     (lambda (form term pattern)
       (define (equivalent form*) (earlyrew/remember* form* form))
       (define (default)
 	`(CALL (QUOTE ,prim-general-car-cdr) (QUOTE #f) ,term ,pattern))
-      (cond ((form/number? pattern)
+      (cond ((form/exact-integer? pattern)
 	     => (lambda (pattern)
-		  (if (and (integer? pattern) (> pattern 0))
-		      (let walk-bits ((num  pattern)
-				      (text term))
-			(if (= num 1)
-			    text
-			    (walk-bits (quotient num 2)
-				       (equivalent
-					`(CALL (QUOTE ,(if (odd? num)
-							   prim-car
-							   prim-cdr))
-					       (QUOTE #f)
-					       ,text)))))
+		  (if (> pattern 0)
+		      (earlyrew/general-car-cdr term pattern equivalent)
 		      (default))))
 	    (else (default))))))
 
@@ -549,6 +553,20 @@ MIT in each case. |#
 	     (default values))))))
 
 
+(define-rewrite/early/global 'LIST-REF 2
+  (lambda (form default* term index)
+    (define (default) (default* (list term index)))
+    (define (equivalent form*) (earlyrew/remember* form* form))
+    (cond ((form/exact-integer? index)
+	   => (lambda (index)
+		(if (and (<= 0 index)
+			 (<= index (if compiler:generate-type-checks? 2 6)))
+		    (earlyrew/general-car-cdr term (* 3 (expt 2 index))
+					      equivalent)
+		    (default))))
+	  (else (default)))))
+
+
 (define-rewrite/early/global 'SQRT 1
   (lambda (form default arg)
     form				; ignored
-- 
2.25.1