From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 13 Feb 2003 04:26:01 +0000 (+0000)
Subject: Can't use top-level DEFINE-SYNTAX in this file, because it breaks the
X-Git-Tag: 20090517-FFI~2034
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2fcdb2900fbdd50ca24561b67f5abb65bb747852;p=mit-scheme.git

Can't use top-level DEFINE-SYNTAX in this file, because it breaks the
cold load.
---

diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm
index 7180b9d22..dadb345c5 100644
--- a/v7/src/runtime/list.scm
+++ b/v7/src/runtime/list.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: list.scm,v 14.32 2003/02/13 02:35:29 cph Exp $
+$Id: list.scm,v 14.33 2003/02/13 04:26:01 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1994,1995,1996,2000 Massachusetts Institute of Technology
@@ -540,7 +540,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
     (let ((n (length first)))
       (do ((lists rest (cdr lists)))
 	  ((not (pair? lists)))
-	(if (not (= n (length (car lists))))
+	(if (not (fix:= n (length (car lists))))
 	    (error:bad-range-argument (car lists) 'MAP)))))
 
   (if (pair? rest)
@@ -549,84 +549,73 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	  (map-2 first (car rest)))
       (map-1 first)))
 
-(define-syntax mapper
-  (rsc-macro-transformer
-   (lambda (form environment)
-     environment
-     (let ((name (list-ref form 1))
-	   (combiner (list-ref form 2))
-	   (initial-value (list-ref form 3))
-	   (procedure (list-ref form 4))
-	   (first (list-ref form 5))
-	   (rest (list-ref form 6)))
-       `(BEGIN
-	  (DEFINE (MAP-1 L)
-	    (COND ((PAIR? L)
-		   (,combiner (,procedure (CAR L))
-			      (MAP-1 (CDR L))))
-		  ((NULL? L) ,initial-value)
-		  (ELSE (BAD-END))))
-
-	  (DEFINE (MAP-2 L1 L2)
-	    (COND ((AND (PAIR? L1) (PAIR? L2))
-		   (,combiner (,procedure (CAR L1) (CAR L2))
-			      (MAP-2 (CDR L1) (CDR L2))))
-		  ((AND (NULL? L1) (NULL? L2)) ,initial-value)
-		  (ELSE (BAD-END))))
-
-	  (DEFINE (MAP-N LISTS)
-	    (LET N-LOOP ((LISTS LISTS))
-	      (IF (PAIR? (CAR LISTS))
-		  (DO ((LISTS LISTS (CDR LISTS))
-		       (CARS '() (CONS (CAAR LISTS) CARS))
-		       (CDRS '() (CONS (CDAR LISTS) CDRS)))
-		      ((NOT (PAIR? LISTS))
-		       (,combiner (APPLY ,procedure (REVERSE! CARS))
-				  (N-LOOP (REVERSE! CDRS))))
-		    (IF (NOT (PAIR? (CAR LISTS)))
-			(BAD-END)))
-		  (DO ((LISTS LISTS (CDR LISTS)))
-		      ((NOT (PAIR? LISTS)) ,initial-value)
-		    (IF (NOT (NULL? (CAR LISTS)))
-			(BAD-END))))))
-
-	  (DEFINE (BAD-END)
-	    (DO ((LISTS (CONS ,first ,rest) (CDR LISTS)))
-		((NOT (PAIR? LISTS)))
-	      (IF (NOT (LIST? (CAR LISTS)))
-		  (ERROR:WRONG-TYPE-ARGUMENT (CAR LISTS) "list" ',name)))
-	    (LET ((N (LENGTH ,first)))
-	      (DO ((LISTS ,rest (CDR LISTS)))
-		  ((NOT (PAIR? LISTS)))
-		(IF (NOT (= N (LENGTH (CAR LISTS))))
-		    (ERROR:BAD-RANGE-ARGUMENT (CAR LISTS) ',name)))))
-
-	  (IF (PAIR? ,rest)
-	      (IF (PAIR? (CDR ,rest))
-		  (MAP-N (CONS ,first ,rest))
-		  (MAP-2 ,first (CAR ,rest)))
-	    (MAP-1 ,first)))))))
-
-(define (for-each procedure first . rest)
-  (mapper for-each begin unspecific procedure first rest))
-
-;;(define (map procedure first . rest)
-;;  (mapper map cons '() procedure first rest))
-
-(define (map* initial-value procedure first . rest)
-  (mapper map* cons initial-value procedure first rest))
-
-(define (append-map procedure first . rest)
-  (mapper append-map append '() procedure first rest))
-
-(define (append-map* initial-value procedure first . rest)
-  (mapper append-map* append initial-value procedure first rest))
-
-(define (append-map! procedure first . rest)
-  (mapper append-map! append! '() procedure first rest))
-
-(define (append-map*! initial-value procedure first . rest)
-  (mapper append-map*! append! initial-value procedure first rest))
+(define for-each)
+(define map*)
+(define append-map)
+(define append-map*)
+(define append-map!)
+(define append-map*!)
+
+(let-syntax
+    ((mapper
+      (rsc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((name (list-ref form 1))
+	       (extra-vars (list-ref form 2))
+	       (combiner (list-ref form 3))
+	       (initial-value (list-ref form 4)))
+	   `(SET! ,name
+		  (NAMED-LAMBDA (,name ,@extra-vars PROCEDURE FIRST . REST)
+		    (DEFINE (MAP-1 L)
+		      (COND ((PAIR? L)
+			     (,combiner (PROCEDURE (CAR L))
+					(MAP-1 (CDR L))))
+			    ((NULL? L) ,initial-value)
+			    (ELSE (BAD-END))))
+		    (DEFINE (MAP-2 L1 L2)
+		      (COND ((AND (PAIR? L1) (PAIR? L2))
+			     (,combiner (PROCEDURE (CAR L1) (CAR L2))
+					(MAP-2 (CDR L1) (CDR L2))))
+			    ((AND (NULL? L1) (NULL? L2)) ,initial-value)
+			    (ELSE (BAD-END))))
+		    (DEFINE (MAP-N LISTS)
+		      (LET N-LOOP ((LISTS LISTS))
+			(IF (PAIR? (CAR LISTS))
+			    (DO ((LISTS LISTS (CDR LISTS))
+				 (CARS '() (CONS (CAAR LISTS) CARS))
+				 (CDRS '() (CONS (CDAR LISTS) CDRS)))
+				((NOT (PAIR? LISTS))
+				 (,combiner (APPLY PROCEDURE (REVERSE! CARS))
+					    (N-LOOP (REVERSE! CDRS))))
+			      (IF (NOT (PAIR? (CAR LISTS)))
+				  (BAD-END)))
+			    (DO ((LISTS LISTS (CDR LISTS)))
+				((NOT (PAIR? LISTS)) ,initial-value)
+			      (IF (NOT (NULL? (CAR LISTS)))
+				  (BAD-END))))))
+		    (DEFINE (BAD-END)
+		      (DO ((LISTS (CONS FIRST REST) (CDR LISTS)))
+			  ((NOT (PAIR? LISTS)))
+			(IF (NOT (LIST? (CAR LISTS)))
+			    (ERROR:WRONG-TYPE-ARGUMENT (CAR LISTS) "list"
+						       ',name)))
+		      (LET ((N (LENGTH FIRST)))
+			(DO ((LISTS REST (CDR LISTS)))
+			    ((NOT (PAIR? LISTS)))
+			  (IF (NOT (FIX:= N (LENGTH (CAR LISTS))))
+			      (ERROR:BAD-RANGE-ARGUMENT (CAR LISTS) ',name)))))
+		    (IF (PAIR? REST)
+			(IF (PAIR? (CDR REST))
+			    (MAP-N (CONS FIRST REST))
+			    (MAP-2 FIRST (CAR REST)))
+			(MAP-1 FIRST)))))))))
+  (mapper for-each () begin unspecific)
+  (mapper map* (initial-value) cons initial-value)
+  (mapper append-map () append '())
+  (mapper append-map* (initial-value) append initial-value)
+  (mapper append-map! () append! '())
+  (mapper append-map*! (initial-value) append! initial-value))
 
 (define mapcan append-map!)
 (define mapcan* append-map*!)