[plt-scheme] Reimplementation of srfi-26 (cut and cute)

On Wed, Jul 20, 2005 at 09:40:04PM +0200, Jens Axel Søgaard wrote:
> Attached is a reimplementation of srfi-26 with
> better error messages than the original.

I just tried this out, and found that the reimplementation does not
follow the spec. The SRFI allows a <slot-or-expr> as the first argument
to cut or cute, hence making a slot at the operator position perfectly
legal.

> ; Examples of errors with better error messages:
> ;   (cut <>)

So this should not be an error, but should be expanded as (lambda (f)
(f)). Similarly (cut <> 3 4) should be expanded as (lambda (f) (f 3 4)).
     
Attached is the trivial patch for fixing this. I also removed the
special error handling for (cut <...> ...). Whether it even should be an
error is arguable, and if it should, then the macro should check _all_
non-tail occurrences of <...>, not just at the operator position.

Cheers,


Lauri
-------------- next part --------------
--- cut.ss.old	2006-01-22 02:55:29.000000000 +0200
+++ cut.ss	2006-01-22 02:31:38.000000000 +0200
@@ -55,12 +55,4 @@
         [(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)]
-        [(cut proc)
-         #'(lambda () (proc))]
-        [(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)]
         [(cut proc slot-or-expr ... <...>)
          ;;   Applying a wrong number of arguments to the the lamba generated by cut, will provoke an
@@ -70,15 +62,15 @@
          ;;   Note: Is it possible to propagate the error to the location of the wrong application
          ;;         in the user code?
-         (generate-names/exprs #'(slot-or-expr ...)
+         (generate-names/exprs #'(proc slot-or-expr ...)
                                (lambda (slot-names names-or-exprs . ignored)
                                  #`(lambda (#, at slot-names . xs)
                                      #,(quasisyntax/loc stx
-                                                        (apply proc #, at names-or-exprs xs)))))]
+                                                        (apply #, at names-or-exprs xs)))))]
         [(cut proc slot-or-expr ...)
-         (generate-names/exprs #'(slot-or-expr ...)
+         (generate-names/exprs #'(proc slot-or-expr ...)
                                (lambda (slot-names names-or-exprs . ignored)
                                  #`(lambda #,slot-names
                                      #,(quasisyntax/loc stx
-                                                        (proc #, at names-or-exprs)))))]))
+                                                        (#, at names-or-exprs)))))]))
     
           ;  In addition to cut, there is a variant called cute (a mnemonic for
@@ -95,24 +87,16 @@
         [(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)]
-        [(cute <...> slot-or-expr ...)
-         (raise-syntax-error #f "cute expects an expression at the first position, given <...>" stx)]
         [(cute proc slot-or-expr ... <...>)
-         (generate-names/exprs #'(slot-or-expr ...)
+         (generate-names/exprs #'(proc slot-or-expr ...)
                                (lambda (slot-names ignored names bindings)
                                  #`(let #,bindings
                                      (lambda (#, at slot-names . xs)
-                                       (apply proc #, at names xs)))))]
+                                       (apply #, at names xs)))))]
         [(cute proc slot-or-expr ...)
-         (generate-names/exprs #'(slot-or-expr ...)
+         (generate-names/exprs #'(proc slot-or-expr ...)
                                (lambda (slot-names ignored names bindings)
                                  #`(let #,bindings
                                      (lambda #,slot-names
-                                       (proc #, at names)))))]))
+                                       (#, at names)))))]))
     )