From 2fcdb2900fbdd50ca24561b67f5abb65bb747852 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 13 Feb 2003 04:26:01 +0000 Subject: [PATCH] Can't use top-level DEFINE-SYNTAX in this file, because it breaks the cold load. --- v7/src/runtime/list.scm | 149 +++++++++++++++++++--------------------- 1 file changed, 69 insertions(+), 80 deletions(-) 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*!) -- 2.25.1