From 59bdd5c6fdf8d2857fbe3d0e6d0d876a8e7c3a07 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 31 Jul 2011 23:24:43 +0000
Subject: [PATCH] Fix {REDUCE,REPLACE}-OPERATOR declaration after jrm's sf
 rototill.

---
 src/sf/pardec.scm |  4 ++--
 src/sf/reduct.scm | 56 +++++++++++++++++++----------------------------
 2 files changed, 25 insertions(+), 35 deletions(-)

diff --git a/src/sf/pardec.scm b/src/sf/pardec.scm
index 2d027e5e1..a3059b073 100644
--- a/src/sf/pardec.scm
+++ b/src/sf/pardec.scm
@@ -405,9 +405,9 @@ USA.
 	 replacements)))
 
 (define (make-dumpable-expander expander declaration)
-  (make-entity (lambda (self expr operands if-expanded if-not-expanded block)
+  (make-entity (lambda (self expr operands block)
 		 self			; ignored
-		 (expander expr operands if-expanded if-not-expanded block))
+		 (expander expr operands block))
 	       (cons '*DUMPABLE-EXPANDER* declaration)))
 
 (define (dumpable-expander? object)
diff --git a/src/sf/reduct.scm b/src/sf/reduct.scm
index 46b6014fc..ebaa4f596 100644
--- a/src/sf/reduct.scm
+++ b/src/sf/reduct.scm
@@ -304,7 +304,7 @@ Examples:
 		     (lambda (block x y)
 		       (combine-2 block (expr block) x y)))))))
 
-      (lambda (expr operands if-expanded if-not-expanded block)
+      (lambda (expr operands block)
 	(define (group l)
 	  (if (null? (cdr l))
 	      (last block (car l) binop)
@@ -316,28 +316,19 @@ Examples:
 		(let ((l (length operands)))
 		  (or (< l min-args)
 		      (and max-args (> l max-args)))))
-	    (if-not-expanded)
-	    (if-expanded
-	     (reassign
-	      expr
-	      (let ((l1 (list-head operands spare-args))
-		    (l2 (map2 (list-tail operands spare-args))))
-		(cond ((null? l2)
-		       (wrap block
-			     l1
-			     (none block)))
-		      ((null? (cdr l2))
-		       (wrap block
-			     l1
-			     (single block
-				     (car l2)
-				     (lambda (block x y)
-				       (binop block x y)))))
-		      (else
-		       (wrap block
-			     l1
-			     (binop block (car l2)
-				    (group (cdr l2))))))))))))))
+	    #f
+	    (reassign
+	     expr
+	     (let ((l1 (list-head operands spare-args))
+		   (l2 (map2 (list-tail operands spare-args))))
+	       (cond ((null? l2)
+		      (wrap block l1 (none block)))
+		     ((null? (cdr l2))
+		      (wrap block l1 (single block (car l2) binop)))
+		     (else
+		      (wrap block
+			    l1
+			    (binop block (car l2) (group (cdr l2)))))))))))))
 
 (define (group-right spare-args min-args max-args
 		     binop source-block exprs
@@ -504,7 +495,7 @@ Examples:
 			   (cdr replacement)
 			   decl-block))
     (lambda (table default)
-      (lambda (expr operands if-expanded if-not-expanded block)
+      (lambda (expr operands block)
 	(let* ((len (length operands))
 	       (candidate (or (and (< len (vector-length table))
 				   (vector-ref table len))
@@ -514,15 +505,14 @@ Examples:
 		       (block/limited-lookup block
 					     (car candidate)
 					     decl-block)))
-	      (if-not-expanded)
-	      (if-expanded
-	       (combination/make (and expr (object/scode expr))
-				 block
-				 (let ((frob (cdr candidate)))
-				   (if (variable? frob)
-				       (lookup (variable/name frob) block)
-				       frob))
-				 operands))))))))
+	      #f
+	      (combination/make (and expr (object/scode expr))
+				block
+				(let ((frob (cdr candidate)))
+				  (if (variable? frob)
+				      (lookup (variable/name frob) block)
+				      frob))
+				operands)))))))
 
 (define (parse-replacement name ocases block)
   (define (collect len cases default)
-- 
2.25.1