From 02277342ac34c72783dd537e669fe713afa101c1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 11 Nov 2008 22:25:24 +0000 Subject: [PATCH] substitute Scheme-implemented map, for-each, andmap, and ormap in scheme/base and mzscheme, since the JIT generates faster code for the common 1- and 2-argument cases svn: r12393 --- collects/scheme/mzscheme.ss | 2 + collects/scheme/private/map.ss | 130 ++++++++++++++++++++++++++++ collects/scheme/private/pre-base.ss | 2 + collects/tests/mzscheme/basic.ss | 8 ++ 4 files changed, 142 insertions(+) create mode 100644 collects/scheme/private/map.ss diff --git a/collects/scheme/mzscheme.ss b/collects/scheme/mzscheme.ss index 9fd0cc869d..2ea2b9999f 100644 --- a/collects/scheme/mzscheme.ss +++ b/collects/scheme/mzscheme.ss @@ -14,6 +14,7 @@ "private/old-rp.ss" "private/old-if.ss" "private/old-procs.ss" + "private/map.ss" ; shadows #%kernel bindings "promise.ss" (only "private/cond.ss" old-cond) "tcp.ss" @@ -86,6 +87,7 @@ (rename list list-immutable) make-namespace #%top-interaction + map for-each andmap ormap (rename datum #%datum) (rename mzscheme-in-stx-module-begin #%module-begin) (rename #%module-begin #%plain-module-begin) diff --git a/collects/scheme/private/map.ss b/collects/scheme/private/map.ss new file mode 100644 index 0000000000..c30c179da4 --- /dev/null +++ b/collects/scheme/private/map.ss @@ -0,0 +1,130 @@ + +;; #%kernel implements `map', `for-each', `andmap', and `ormap', +;; but the JIT generates faster code, especially for the common cases. + +(module map '#%kernel + (#%require '#%utils ; built into mzscheme + "more-scheme.ss" "small-scheme.ss" "define.ss") + + (#%provide (rename map2 map) + (rename for-each2 for-each) + (rename andmap2 andmap)) + + ;; ------------------------------------------------------------------------- + + (define map2 + (let ([map + (case-lambda + [(f l) + (if (and (procedure? f) + (procedure-arity-includes? f 1) + (list? l)) + (let loop ([l l]) + (cond + [(null? l) null] + [else (cons (f (car l)) (loop (cdr l)))])) + (map f l))] + [(f l1 l2) + (if (and (procedure? f) + (procedure-arity-includes? f 2) + (list? l1) + (list? l2) + (= (length l1) (length l2))) + (let loop ([l1 l1][l2 l2]) + (cond + [(null? l1) null] + [else (cons (f (car l1) (car l2)) + (loop (cdr l1) (cdr l2)))])) + (map f l1 l2))] + [(f . args) (apply map f args)])]) + map)) + + (define for-each2 + (let ([for-each + (case-lambda + [(f l) + (if (and (procedure? f) + (procedure-arity-includes? f 1) + (list? l)) + (let loop ([l l]) + (cond + [(null? l) (void)] + [else (begin (f (car l)) (loop (cdr l)))])) + (for-each f l))] + [(f l1 l2) + (if (and (procedure? f) + (procedure-arity-includes? f 2) + (list? l1) + (list? l2) + (= (length l1) (length l2))) + (let loop ([l1 l1][l2 l2]) + (cond + [(null? l1) (void)] + [else (begin (f (car l1) (car l2)) + (loop (cdr l1) (cdr l2)))])) + (for-each f l1 l2))] + [(f . args) (apply for-each f args)])]) + for-each)) + + (define andmap2 + (let ([andmap + (case-lambda + [(f l) + (if (and (procedure? f) + (procedure-arity-includes? f 1) + (list? l)) + (if (null? l) + #t + (let loop ([l l]) + (cond + [(null? (cdr l)) (f (car l))] + [else (and (f (car l)) (loop (cdr l)))]))) + (andmap f l))] + [(f l1 l2) + (if (and (procedure? f) + (procedure-arity-includes? f 2) + (list? l1) + (list? l2) + (= (length l1) (length l2))) + (if (null? l1) + #t + (let loop ([l1 l1][l2 l2]) + (cond + [(null? (cdr l1)) (f (car l1) (car l2))] + [else (and (f (car l1) (car l2)) + (loop (cdr l1) (cdr l2)))]))) + (andmap f l1 l2))] + [(f . args) (apply andmap f args)])]) + andmap)) + + (define ormap2 + (let ([ormap + (case-lambda + [(f l) + (if (and (procedure? f) + (procedure-arity-includes? f 1) + (list? l)) + (if (null? l) + #f + (let loop ([l l]) + (cond + [(null? (cdr l)) (f (car l))] + [else (or (f (car l)) (loop (cdr l)))]))) + (ormap f l))] + [(f l1 l2) + (if (and (procedure? f) + (procedure-arity-includes? f 2) + (list? l1) + (list? l2) + (= (length l1) (length l2))) + (if (null? l1) + #f + (let loop ([l1 l1][l2 l2]) + (cond + [(null? (cdr l1)) (f (car l1) (car l2))] + [else (or (f (car l1) (car l2)) + (loop (cdr l1) (cdr l2)))]))) + (ormap f l1 l2))] + [(f . args) (apply ormap f args)])]) + ormap))) + \ No newline at end of file diff --git a/collects/scheme/private/pre-base.ss b/collects/scheme/private/pre-base.ss index 83433586c9..dfa2cd6da0 100644 --- a/collects/scheme/private/pre-base.ss +++ b/collects/scheme/private/pre-base.ss @@ -12,6 +12,7 @@ "reqprov.ss" "modbeg.ss" "for.ss" + "map.ss" ; shadows #%kernel bindings '#%builtin) ; so it's attached @@ -74,6 +75,7 @@ (all-from "for.ss") #%top-interaction + map for-each andmap ormap make-keyword-procedure (rename new-keyword-apply keyword-apply) procedure-keywords diff --git a/collects/tests/mzscheme/basic.ss b/collects/tests/mzscheme/basic.ss index f492b0e285..da173fe978 100644 --- a/collects/tests/mzscheme/basic.ss +++ b/collects/tests/mzscheme/basic.ss @@ -1371,13 +1371,21 @@ (err/rt-test (map (lambda (x) (values 1 2)) '(1 2)) arity?) (test #t andmap add1 null) +(test #t andmap < null null) (test #f ormap add1 null) +(test #f ormap < null null) (test #f andmap positive? '(1 -2 3)) (test #t ormap positive? '(1 -2 3)) +(test #f andmap < '(1 -2 3) '(2 2 3)) +(test #t ormap < '(1 -2 3) '(0 2 4)) (test #f andmap negative? '(1 -2 3)) (test #t ormap negative? '(1 -2 3)) +(test #t andmap < '(1 -2 3) '(2 2 4)) +(test #f ormap < '(1 -2 3) '(0 -2 3)) (test 4 andmap add1 '(1 2 3)) (test 2 ormap add1 '(1 2 3)) +(test #t andmap < '(1 -2 3) '(2 2 4) '(5 6 7)) +(test #t ormap < '(1 -2 3) '(0 -2 4) '(0 0 8)) (err/rt-test (ormap (lambda (x) (values 1 2)) '(1 2)) arity?) (err/rt-test (andmap (lambda (x) (values 1 2)) '(1 2)) arity?)