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 7180b9d22e619681779b041144eb86ef6cf25d4e..dadb345c59f3db50c4cc1696d71a61fc6a161075 100644 (file)
--- 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)))
 \f
-(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))
 \f
 (define mapcan append-map!)
 (define mapcan* append-map*!)