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

add 'compose' to scheme/base; switch Help Desk to a mzscheme app

Browse Source 
svn: r7979

original commit: bd7ced966ed54fedd5608a68ef8ec212a913e30d
This commit is contained in:
Matthew Flatt 2007-12-12 22:17:09 +00:00
parent c82a619504
commit 7a8cb124d1
1 changed files with 2 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/mzlib/etc.ss
View File

@ -5,7 +5,8 @@
(only scheme/base
build-string
build-list
build-vector)
build-vector
compose)
"kw.ss")
(require-for-syntax (lib "kerncase.ss" "syntax")
@ -53,29 +54,6 @@
(define identity (lambda (x) x))
(define compose
(case-lambda
[(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
[(f g)
(let ([f (compose f)]
[g (compose g)])
(if (eqv? 1 (procedure-arity f)) ; optimize: don't use call-w-values
(if (eqv? 1 (procedure-arity g)) ; optimize: single arity everywhere
(lambda (x) (f (g x)))
(lambda args (f (apply g args))))
(if (eqv? 1 (procedure-arity g)) ; optimize: single input
(lambda (a)
(call-with-values
(lambda () (g a))
f))
(lambda args
(call-with-values
(lambda () (apply g args))
f)))))]
[(f . more)
(let ([m (apply compose more)])
(compose f m))]))
(define (loop-until start done? next body)
(let loop ([i start])
(unless (done? i)