suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
svn: r12393
This commit is contained in:
Matthew Flatt 2008-11-11 22:25:24 +00:00
parent 34c5db31ef
commit 02277342ac
4 changed files with 142 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/scheme/mzscheme.ss
View File

@ -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)

130
collects/scheme/private/map.ss Normal file
View File

@ -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)))

2
collects/scheme/private/pre-base.ss
View File

@ -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

8
collects/tests/mzscheme/basic.ss
View File

@ -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?)