From 208a4631122ab74c95fd0d4b10b2f7a7fc52bf63 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Thu, 16 Mar 2006 06:31:54 +0000
Subject: [PATCH] patched version from Jens (PR7824)

svn: r2440
---
 collects/srfi/26/cut.ss | 42 ++++++++++++++++++++++++++++-------------
 1 file changed, 29 insertions(+), 13 deletions(-)

diff --git a/collects/srfi/26/cut.ss b/collects/srfi/26/cut.ss
index c50d871c62..3311684ce9 100644
--- a/collects/srfi/26/cut.ss
+++ b/collects/srfi/26/cut.ss
@@ -5,8 +5,6 @@
 
 ; Examples of errors with better error messages:
 ;   (cut)
-;   (cut <>)
-;   (cut <...>)
 ;   ((cut cons <> <>) 1 2 3)
 
 (module cut mzscheme
@@ -55,13 +53,23 @@
         [(cut)
          (raise-syntax-error #f "cut expects 1 or more slots or expressions, given none"  stx)]
         [(cut <>)
-         (raise-syntax-error #f "cut expects an expression at the first position, given a slot <>" stx)]
+         #'(lambda (f) (f))]
+        [(cut <...> slot-or-expr ...)
+         (raise-syntax-error #f "cut expects a a slot or an expression at the first position, given <...>" stx)]
         [(cut proc)
          #'(lambda () (proc))]
+        [(cut <> slot-or-expr ... <...>)
+         (generate-names/exprs #'(slot-or-expr ...)
+                               (lambda (slot-names names-or-exprs . ignored)
+                                 #`(lambda (f . xs)
+                                     #,(quasisyntax/loc stx
+                                         (apply f #,@names-or-exprs xs)))))]
         [(cut <> slot-or-expr ...)
-         (raise-syntax-error #f "cut expects an expression at the first position, given a slot <>" stx)]
-        [(cut <...> slot-or-expr ...)
-         (raise-syntax-error #f "cut expects an expression at the first position, given <...>" stx)]
+         (generate-names/exprs #'(slot-or-expr ...)
+                               (lambda (slot-names names-or-exprs . ignored)
+                                 #`(lambda (f)
+                                     #,(quasisyntax/loc stx
+                                         (f #,@names-or-exprs)))))]
         [(cut proc slot-or-expr ... <...>)
          ;;   Applying a wrong number of arguments to the the lamba generated by cut, will provoke an
          ;; error caused by the application (proc ...). The quasisyntax/loc makes sure DrScheme
@@ -95,13 +103,23 @@
         [(cute)
          (raise-syntax-error #f "cute expects 1 or more slots or expressions, given none"  stx)]
         [(cute <>)
-         (raise-syntax-error #f "cute expects an expression at the first position, given a slot <>" stx)]
-        [(cute proc)
-         #'(lambda () (proc))]
-        [(cute <> slot-or-expr ...)
-         (raise-syntax-error #f "cute expects an expression at the first position, given a slot <>" stx)]
+         #'(lambda (f) (f))]
         [(cute <...> slot-or-expr ...)
          (raise-syntax-error #f "cute expects an expression at the first position, given <...>" stx)]
+        [(cute proc)
+         #'(lambda () (proc))]
+        [(cute <> slot-or-expr ... <...>)
+         (generate-names/exprs #'(slot-or-expr ...)
+                               (lambda (slot-names ignored names bindings)
+                                 #`(let #,bindings
+                                     (lambda (f #,@slot-names . xs)
+                                       (apply f #,@names xs)))))]
+        [(cute <> slot-or-expr ...)
+         (generate-names/exprs #'(slot-or-expr ...)
+                               (lambda (slot-names ignored names bindings)
+                                 #`(let #,bindings
+                                     (lambda (f #,@slot-names)
+                                       (f #,@names)))))]
         [(cute proc slot-or-expr ... <...>)
          (generate-names/exprs #'(slot-or-expr ...)
                                (lambda (slot-names ignored names bindings)
@@ -115,5 +133,3 @@
                                      (lambda #,slot-names
                                        (proc #,@names)))))]))
     )
-
-