From 17b6ffa731043fce9180ad69cc246adfd799f83a Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Mon, 6 Jun 2011 12:41:34 -0400
Subject: [PATCH] Move `thunk' from `unstable/function' into `racket/function'.

Actually, the new `thunk' is a nullary function, which I think is very
popular expectation for the name.  Since there are possible uses for the
any-arity version, it's added too, as `thunk*'.
---
 collects/racket/function.rkt                  | 23 +++++++++++++++++--
 .../scribblings/reference/procedures.scrbl    | 19 +++++++++++++++
 collects/tests/racket/function.rktl           | 13 +++++++++++
 collects/unstable/function.rkt                | 21 -----------------
 collects/unstable/scribblings/function.scrbl  | 15 ------------
 5 files changed, 53 insertions(+), 38 deletions(-)

diff --git a/collects/racket/function.rkt b/collects/racket/function.rkt
index 4883f26b98..da8648cc05 100644
--- a/collects/racket/function.rkt
+++ b/collects/racket/function.rkt
@@ -1,6 +1,8 @@
-#lang scheme/base
+#lang racket/base
 
-(provide identity const negate curry curryr)
+(require (for-syntax racket/base syntax/name))
+
+(provide identity const thunk thunk* negate curry curryr)
 
 (define (identity x) x)
 
@@ -8,6 +10,23 @@
   (define (const . _) c)
   (make-keyword-procedure const const))
 
+(define-syntax (thunk stx)
+  (syntax-case stx ()
+    [(_ body0 body ...) (syntax/loc stx (lambda () body0 body ...))]))
+
+(define-syntax (thunk* stx)
+  (syntax-case stx ()
+    [(_ body0 body ...)
+     (with-syntax ([proc (syntax-property
+                          (syntax/loc stx
+                            ;; optimize 0- and 1-argument cases
+                            (case-lambda [() body0 body ...]
+                                         [(x) (th)] [xs (th)]))
+                          'inferred-name (syntax-local-infer-name stx))])
+       (syntax/loc stx
+         (letrec ([th proc])
+           (make-keyword-procedure (lambda (_1 _2 . _3) (th)) proc))))]))
+
 (define (negate f)
   (unless (procedure? f) (raise-type-error 'negate "procedure" f))
   (let-values ([(arity) (procedure-arity f)]
diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl
index bbdda6a545..9cb21dfbbb 100644
--- a/collects/scribblings/reference/procedures.scrbl
+++ b/collects/scribblings/reference/procedures.scrbl
@@ -495,6 +495,25 @@ Returns a procedure that accepts any arguments and returns @scheme[v].
 ((const 'foo))
 ]}
 
+@deftogether[(@defform[(thunk  body ...+)]
+              @defform[(thunk* body ...+)])]{
+
+@scheme[thunk] creates a nullary function that evaluates the given body.
+@scheme[thunk*] is similar, except that the resulting function accepts
+any number of inputs and keyword arguments.
+
+@defexamples[
+#:eval the-eval
+(define th1 (thunk (define x 1) (printf "~a\n" x)))
+(th1)
+(th1 'x)
+(th1 #:y 'z)
+(define th2 (thunk* (define x 1) (printf "~a\n" x)))
+(th2)
+(th2 'x)
+(th2 #:y 'z)
+]}
+
 @defproc[(negate [proc procedure?]) procedure?]{
 
 Returns a procedure that is just like @scheme[proc], except that it
diff --git a/collects/tests/racket/function.rktl b/collects/tests/racket/function.rktl
index 3278c50d4f..be1effcf2b 100644
--- a/collects/tests/racket/function.rktl
+++ b/collects/tests/racket/function.rktl
@@ -56,6 +56,19 @@
   (test 'foo (const 'foo) 1)
   (test 'foo (const 'foo) 1 2 3 4 5))
 
+;; ---------- thunk ----------
+(let ([th1 (thunk 'foo)] [th2 (thunk* 'bar)])
+  (test #t procedure? th1)
+  (test #t procedure? th2)
+  (test 0 procedure-arity th1)
+  (test (arity-at-least 0) procedure-arity th2)
+  (test 'foo th1)
+  (err/rt-test (th1 1))
+  (test 'bar th2)
+  (test 'bar th2 1)
+  (test 'bar th2 1 2 3)
+  (test 'bar th2 1 #:x 2 3 #:y 4 5))
+
 ;; ---------- negate ----------
 (let ()
   (define *not  (negate not))
diff --git a/collects/unstable/function.rkt b/collects/unstable/function.rkt
index be671d1fa3..3f83762f2f 100644
--- a/collects/unstable/function.rkt
+++ b/collects/unstable/function.rkt
@@ -85,26 +85,6 @@
         (let* ([name (case-lambda keyword-clause)]) name)
         (let* ([name (case-lambda* positional-clause ...)]) name)))]))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;;  Degenerate Functions
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-syntax (thunk stx)
-  (syntax-case stx ()
-    [(thunk body ...)
-     (syntax/loc stx
-       (make-keyword-thunk (lambda () body ...)))]))
-
-(define (make-keyword-thunk f)
-  (make-intermediate-procedure
-   'thunk-function
-    [(x ... 8) (f)]
-    [xs (f)]
-    #:keyword
-    [(ks vs . xs) (f)]))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  Higher-Order Boolean Operations
@@ -363,7 +343,6 @@
 
 (provide
  ;; functions
- thunk
  conjoin disjoin
  curryn currynr papply papplyr call
  ;; macros
diff --git a/collects/unstable/scribblings/function.scrbl b/collects/unstable/scribblings/function.scrbl
index c381e44ced..05cd91b286 100644
--- a/collects/unstable/scribblings/function.scrbl
+++ b/collects/unstable/scribblings/function.scrbl
@@ -14,21 +14,6 @@ This module provides tools for higher-order programming and creating functions.
 
 @section{Simple Functions}
 
-@defform[(thunk body ...)]{
-
-Creates a function that ignores its inputs and evaluates the given body.  Useful
-for creating event handlers with no (or irrelevant) arguments.
-
-@defexamples[
-#:eval the-eval
-(define f (thunk (define x 1) (printf "~a\n" x)))
-(f)
-(f 'x)
-(f #:y 'z)
-]
-
-}
-
 @section{Higher Order Predicates}
 
 @defproc[((negate [f (-> A ... boolean?)]) [x A] ...) boolean?]{