From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Thu, 11 Feb 2010 02:16:32 +0000 (-0800)
Subject: Add expansion for EQ?
X-Git-Tag: 20100708-Gtk~168^2~5
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=eb6eef44f1db89086cb49e16eb0ed45f9979c2e7;p=mit-scheme.git

Add expansion for EQ?
---

diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm
index 585f98e35..155c5612b 100644
--- a/src/sf/usiexp.scm
+++ b/src/sf/usiexp.scm
@@ -462,6 +462,20 @@ USA.
 
 ;;;; Miscellaneous
 
+(define (eq?-expansion expr operands block)
+  (if (and (pair? operands)
+	   (pair? (cdr operands))
+	   (not (pair? (cddr operands))))
+      ;; Convert (eq? <expr> #f) and (eq? #f <expr>) to (not <expr>)
+      ;; Conditional inversion will remove the call to not.
+      (cond ((constant-eq? (first operands) #f)
+	     (make-combination expr block (ucode-primitive not) (cdr operands)))
+	    ((constant-eq? (second operands) #f)
+	     (make-combination expr block (ucode-primitive not) (list (car operands))))
+	    (else
+	     (make-combination expr block (ucode-primitive eq?) operands)))
+      #f))
+
 (define (make-string-expansion expr operands block)
   (if (and (pair? operands)
 	   (null? (cdr operands)))
@@ -481,7 +495,7 @@ USA.
 (define (exact-integer?-expansion expr operands block)
   (if (and (pair? operands)
 	   (null? (cdr operands)))
-      (make-operand-binding 
+      (make-operand-binding
        expr block (car operands)
        (lambda (block operand)
 	 (make-disjunction
@@ -519,7 +533,7 @@ USA.
 (define (symbol?-expansion expr operands block)
   (if (and (pair? operands)
 	   (null? (cdr operands)))
-      (make-operand-binding 
+      (make-operand-binding
        expr block (car operands)
        (lambda (block operand)
 	 (make-disjunction
@@ -636,6 +650,7 @@ USA.
 	    exact-integer?
 	    exact-rational?
 	    expt
+	    eq?
 	    fifth
 	    first
 	    fix:<=
@@ -717,6 +732,7 @@ USA.
 	   exact-integer?-expansion
 	   exact-rational?-expansion
 	   expt-expansion
+	   eq?-expansion
 	   fifth-expansion
 	   first-expansion
 	   fix:<=-expansion