Add `compose', `negate', and `const'.

* module/ice-9/boot-9.scm (compose, negate, const): New procedures.

* doc/ref/api-procedures.texi (Higher-Order Functions): New node.

* test-suite/Makefile.am (SCM_TESTS): Add `tests/procs.test'.

* test-suite/tests/procs.test: New file.

diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index 8fc7f33..c087f4c 100644 (file)
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -13,6 +13,7 @@
 * Compiled Procedures::         Scheme procedures can be compiled.
 * Optional Arguments::          Handling keyword, optional and rest arguments.
 * Case-lambda::                 One function, multiple arities.
+* Higher-Order Functions::      Function that take or return functions.
 * Procedure Properties::        Procedure properties and meta-information.
 * Procedures with Setters::     Procedures with setters.
 @end menu
@@ -573,6 +574,62 @@ arguments, and on the predicate; keyword arguments may be present but
 do not contribute to the ``success'' of a match. In fact a bad keyword
 argument list may cause an error to be raised.
 
+@node Higher-Order Functions
+@subsection Higher-Order Functions
+
+@cindex higher-order functions
+
+As a functional programming language, Scheme allows the definition of
+@dfn{higher-order functions}, i.e., functions that take functions as
+arguments and/or return functions.  Utilities to derive procedures from
+other procedures are provided and described below.
+
+@deffn {Scheme Procedure} const value
+Return a procedure that accepts any number of arguments and returns
+@var{value}.
+
+@lisp
+(procedure? (const 3))        @result{} #t
+((const 'hello))              @result{} hello
+((const 'hello) 'world)       @result{} hello
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} negate proc
+Return a procedure with the same arity as @var{proc} that returns the
+@code{not} of @var{proc}'s result.
+
+@lisp
+(procedure? (negate number?)) @result{} #t
+((negate odd?) 2)             @result{} #t
+((negate real?) 'dream)       @result{} #t
+((negate string-prefix?) "GNU" "GNU Guile")
+                              @result{} #f
+(filter (negate number?) '(a 2 "b"))
+                              @result{} (a "b")
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} compose proc rest ...
+Compose @var{proc} with the procedures in @var{rest}, such that the last
+one in @var{rest} is applied first and @var{proc} last, and return the
+resulting procedure.  The given procedures must have compatible arity.
+
+@lisp
+(procedure? (compose 1+ 1-)) @result{} #t
+((compose sqrt 1+ 1+) 2)     @result{} 2.0
+((compose 1+ sqrt) 3)        @result{} 2.73205080756888
+(eq? (compose 1+) 1+)        @result{} #t
+
+((compose zip unzip2) '((1 2) (a b)))
+                             @result{} ((1 2) (a b))
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} identity x
+Return X.
+@end deffn
+
 @node Procedure Properties
 @subsection Procedure Properties and Meta-information
 

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 1a61ce0..1b2985d 100644 (file)
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -531,6 +531,29 @@ If there is no handler at all, Guile prints an error and then exits."
 ;;;
 
 (define (identity x) x)
+
+(define (compose proc . rest)
+  "Compose PROC with the procedures in REST, such that the last one in
+REST is applied first and PROC last, and return the resulting procedure.
+The given procedures must have compatible arity."
+  (if (null? rest)
+      proc
+      (let ((g (apply compose rest)))
+        (lambda args
+          (call-with-values (lambda () (apply g args)) proc)))))
+
+(define (negate proc)
+  "Return a procedure with the same arity as PROC that returns the `not'
+of PROC's result."
+  (lambda args
+    (not (apply proc args))))
+
+(define (const value)
+  "Return a procedure that accepts any number of arguments and returns
+VALUE."
+  (lambda _
+    value))
+
 (define (and=> value procedure) (and value (procedure value)))
 (define call/cc call-with-current-continuation)
 

diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 2e43e87..b1f184e 100644 (file)
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -72,6 +72,7 @@ SCM_TESTS = tests/00-initial-env.test         \
            tests/options.test                  \
            tests/print.test                    \
            tests/procprop.test                 \
+           tests/procs.test                    \
            tests/poe.test                      \
            tests/popen.test                    \
            tests/popen-child.scm               \

diff --git a/test-suite/tests/procs.test b/test-suite/tests/procs.test
new file mode 100644 (file)
index 0000000..c17a021
--- /dev/null
+++ b/test-suite/tests/procs.test
@@ -0,0 +1,48 @@
+;;;; procss.test --- Procedures.      -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;;   Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-procs)
+  #:use-module (srfi srfi-1)
+  #:use-module (test-suite lib))
+
+(with-test-prefix "common procedures"
+
+  (pass-if "identity"
+    (eq? 'a (identity 'a)))
+
+  (pass-if "const"
+    (and (procedure? (const 'a))
+         (eq? 'a ((const 'a)))
+         (eq? 'a ((const 'a) 'b 'c 'd))))
+
+  (pass-if "negate"
+    (and (procedure? (negate number?))
+         ((negate real?) 'dream)
+         ((negate odd?) 0)))
+
+  (with-test-prefix "compose"
+
+    (pass-if "identity"
+      (eq? 1+ (compose 1+)))
+
+    (pass-if "simple"
+      (= 2.0 ((compose sqrt 1+ 1+) 2)))
+
+    (pass-if "multiple values"
+      (equal? ((compose zip unzip2) '((1 2) (a b)))
+              '((1 2) (a b))))))