From 7a8cb124d1faf7b8b8c649badcb1a1093798bf97 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 12 Dec 2007 22:17:09 +0000 Subject: [PATCH] add 'compose' to scheme/base; switch Help Desk to a mzscheme app svn: r7979 original commit: bd7ced966ed54fedd5608a68ef8ec212a913e30d --- collects/mzlib/etc.ss | 26 ++------------------------ 1 file changed, 2 insertions(+), 24 deletions(-) diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 7b15358..23d656c 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -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)