From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 26 Jun 2001 18:52:35 +0000 (+0000)
Subject: Fix problem with optimizer: needed to add notion of default rules that
X-Git-Tag: 20090517-FFI~2703
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2db9bc7d96f76ab449a4141e65cf8035bfc5a0d8;p=mit-scheme.git

Fix problem with optimizer: needed to add notion of default rules that
are used when a more specific pattern isn't available.  Also,
generalize OPTIMIZE-GROUP-EXPRESSION so that it can be used by
VECTOR-APPEND.
---

diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm
index ab9f8dcb5..c8571a300 100644
--- a/v7/src/star-parser/shared.scm
+++ b/v7/src/star-parser/shared.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: shared.scm,v 1.1 2001/06/26 18:03:22 cph Exp $
+;;; $Id: shared.scm,v 1.2 2001/06/26 18:52:35 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -115,8 +115,14 @@
 	  ((and (pair? expression)
 		(symbol? (car expression)))
 	   (let ((expression*
-		  (cons (car expression)
-			(map optimize-expression (cdr expression)))))
+		  (let ((optimizer
+			 (hash-table/get default-optimizers
+					 (car expression)
+					 #f)))
+		    (if optimizer
+			(optimizer expression)
+			(cons (car expression)
+			      (map optimize-expression (cdr expression)))))))
 	     (if (equal? expression* expression)
 		 expression
 		 (optimize-expression expression*))))
@@ -135,6 +141,13 @@
 (define optimizer-patterns
   '())
 
+(define (define-default-optimizer keyword optimizer)
+  (hash-table/put! default-optimizers keyword optimizer)
+  keyword)
+
+(define default-optimizers
+  (make-eq-hash-table))
+
 (define (predicate-not-or expression)
   (not (and (pair? (cadr expression))
 	    (eq? (caadr expression) 'OR))))
@@ -247,23 +260,38 @@
     `(OR ,(cadar (cadr expression))
 	 ,(cadddr (caddr expression)))))
 
-(define-optimizer '('LAMBDA (* IDENTIFIER) EXPRESSION) #f
+(define-optimizer '('LET ((IDENTIFIER EXPRESSION))
+		     ('AND IDENTIFIER
+			   IDENTIFIER))
+    (lambda (expression)
+      (and (eq? (caar (cadr expression))
+		(cadr (caddr expression)))
+	   (eq? (caddr (caddr expression))
+		(cadr (caddr expression)))))
   (lambda (expression)
-    `(LAMBDA ,(cadr expression) ,(optimize-expression (caddr expression)))))
+    (cadar (cadr expression))))
 
-(define-optimizer '('LET IDENTIFIER (* (IDENTIFIER EXPRESSION)) EXPRESSION)
-    #f
+(define-default-optimizer 'LET
   (lambda (expression)
-    `(LET ,(cadr expression)
-       ,(map (lambda (b) (list (car b) (optimize-expression (cadr b))))
-	     (caddr expression))
-       ,(optimize-expression (cadddr expression)))))
+    (if (symbol? (cadr expression))
+	`(LET ,(cadr expression)
+	   ,(map (lambda (binding)
+		   `(,(car binding) ,(optimize-expression (cadr binding))))
+		 (caddr expression))
+	   ,@(map optimize-expression (cdddr expression)))
+	`(LET ,(map (lambda (binding)
+		      `(,(car binding) ,(optimize-expression (cadr binding))))
+		    (cadr expression))
+	   ,@(map optimize-expression (cddr expression))))))
 
-(define-optimizer '('LET (* (IDENTIFIER EXPRESSION)) EXPRESSION) #f
+(define-optimizer '('LAMBDA (* IDENTIFIER) EXPRESSION) #f
   (lambda (expression)
-    `(LET ,(map (lambda (b) (list (car b) (optimize-expression (cadr b))))
-		(cadr expression))
-       ,(optimize-expression (caddr expression)))))
+    `(LAMBDA ,(cadr expression) ,(optimize-expression (caddr expression)))))
+
+(define-default-optimizer 'LAMBDA
+  (lambda (expression)
+    `(LAMBDA ,(cadr expression)
+       ,@(map optimize-expression (cddr expression)))))
 
 (define-optimizer '('VECTOR-MAP EXPRESSION ('VECTOR EXPRESSION)) #f
   (lambda (expression)
@@ -282,15 +310,7 @@
 
 (define-optimizer '('VECTOR-APPEND . (* EXPRESSION)) #f
   (lambda (expression)
-    (let ((expressions
-	   (delete '(VECTOR)
-		   (map optimize-expression
-			(flatten-subexpressions expression)))))
-      (if (pair? expressions)
-	  (if (pair? (cdr expressions))
-	      `(,(car expression) ,@expressions)
-	      (car expressions))
-	  `(VECTOR)))))
+    (optimize-group-expression expression '(VECTOR))))
 
 (define-optimizer '('AND . (* EXPRESSION)) #f
   (lambda (expression)
@@ -307,15 +327,14 @@
 (define (optimize-group-expression expression identity)
   (let loop
       ((expressions
-	(map optimize-expression (flatten-subexpressions expression))))
-    (cond ((not (pair? expressions))
-	   identity)
-	  ((equal? (car (last-pair expressions)) identity)
-	   (loop (except-last-pair! expressions)))
-	  ((pair? (cdr expressions))
-	   `(,(car expression) ,@expressions))
-	  (else
-	   (car expressions)))))
+	(delete identity
+		(map optimize-expression
+		     (flatten-subexpressions expression)))))
+    (if (pair? expressions)
+	(if (pair? (cdr expressions))
+	    `(,(car expression) ,@expressions)
+	    (car expressions))
+	identity)))
 
 (define (flatten-subexpressions expression)
   (flatten-expressions (cdr expression) (car expression)))