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

*** empty log message ***

Browse Source 
original commit: 89756069b913e24574b536f36f9ec87803985644
This commit is contained in:
Matthew Flatt 1997-09-10 12:56:54 +00:00
parent 838b443062
commit 84f81ab101
1 changed files with 16 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/mzlib/functior.ss
View File

@ -7,16 +7,23 @@
(define compose (define compose
(polymorphic (polymorphic
(case-lambda (case-lambda
[(f) f] [(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
[(f g) [(f g)
(let ([f (compose f)]
[g (compose g)])
(if (eqv? 1 (arity f)) ; optimize: don't use call-w-values (if (eqv? 1 (arity f)) ; optimize: don't use call-w-values
(if (eqv? 1 (arity g)) ; optimize: single arity everywhere (if (eqv? 1 (arity g)) ; optimize: single arity everywhere
(lambda (x) (f (g x))) (lambda (x) (f (g x)))
(lambda args (f (apply g args)))) (lambda args (f (apply g args))))
(if (eqv? 1 (arity g)) ; optimize: single input
(lambda (a)
(call-with-values
(lambda () (g a))
f))
(lambda args (lambda args
(call-with-values (call-with-values
(lambda () (apply g args)) (lambda () (apply g args))
f)))] f)))))]
[(f . more) [(f . more)
(let ([m (apply compose more)]) (let ([m (apply compose more)])
(compose f m))]))) (compose f m))])))