fixed PR 8210

svn: r3979

collects/mzlib/etc.ss

@@ -236,18 +236,30 @@
      [(_ x body1 body ...)
       (raise-syntax-error #f "not a definition sequence" stx (syntax x))]))
 
- ;; recur is another name for 'let' in a named let
+  ;; recur is another name for 'let' in a named let
- (define-syntax (recur stx)
+  (define-syntax (recur stx)
-   (syntax-case stx ()
+    (syntax-case stx ()
-     [(_ . rest) (syntax/loc stx (let . rest))]))
+      [(_ . rest) (syntax/loc stx (let . rest))]))
   
- ;; define a recursive value
+  ;; define a recursive value
- (define-syntax (rec stx)
+  ;; implementation by Jens Axel Soegaard
-   (syntax-case stx ()
+  (define-syntax (rec stx)
-     [(_ name expr)
+    (syntax-case stx ()
-      (begin (unless (identifier? (syntax name))
+      [(rec id expr)
-               (raise-syntax-error #f "not an identifier" stx (syntax name)))
+       (identifier? #'id)
-             (syntax/loc stx (letrec ([name expr]) name)))]))
+       #`(letrec ((id expr))
+           #,(syntax-property #'expr 'inferred-name (syntax-e #'id)))]
+      [(rec (name id ...) body ...)
+       (andmap identifier? (syntax->list #'(name id ...)))
+       #`(letrec ((name (lambda (id ...) body ...)))
+           #,(syntax-property #'name 'inferred-name (syntax-e #'name)))]
+      [(rec (name id ... . did) body ...)
+       (andmap identifier? (syntax->list #'(name id ...)))
+       #`(letrec ((name (lambda (id ... . did) body ...)))
+           #,(syntax-property #'name 'inferred-name (syntax-e #'name)))]
+      [_
+       (raise-syntax-error
+        #f "expects either a variable followed by an expresion, or a (possibly dotted) sequence of variables followed by a body" stx)]))
 
  (define-syntax (evcase stx)
    (syntax-case stx ()

collects/srfi/31/rec.ss

@@ -1,48 +1,5 @@
-;;; rec.ss  --  Reimplementation of SRFI 31  -- Jens Axel Soegaard
-; This reimplementation provides better error messages,
-; than the original.
-
-; The inferred-name is set; this gives the proper name in the
-; error message, when the returned procedure is called with
-; the wrong number of arguments.
-
 (module rec mzscheme
-    (provide rec)
+  (provide rec)
+  (require (lib "etc.ss")))
 
-      (define-syntax (rec stx)
-        (syntax-case stx ()
-          [(rec id expr)
-           (identifier? #'id)
-           #`(letrec ((id expr))
-               #,(syntax-property #'expr 'inferred-name (syntax-e #'id)))]
-          [(rec (name id ...) body ...)
-           (andmap identifier? (syntax->list #'(name id ...)))
-           #`(letrec ((name (lambda (id ...) body ...)))
-               #,(syntax-property #'name 'inferred-name (syntax-e #'name)))]
-          [_
-           (raise-syntax-error
-            #f "expects either a variable followed by an expresion, or a list of variables followed by a body" stx)]))
-      )
 
-; Examples of errors caught:
-
-; (rec)
-; (rec 1 1)
-; (rec (a 1 b) 1)
-
-;; Examples of error messages, where the inferred-name is used:
-
-; > ((rec fact
-;     (lambda (n)
-;       (if (= n 0)
-;           1
-;           (* n (fact (- n 1))))))
-;   3 2)
-; procedure fact: expects 1 argument, given 2: 3 2
-
-;> ((rec (fact n)
-;       (if (= n 0)
-;           1
-;           (* n (fact (- n 1)))))
-;   3 2)
-; procedure fact: expects 1 argument, given 2: 3 2

collects/tests/mzscheme/function.ss

@@ -95,4 +95,13 @@
 	       (cons (random 1000) (loop (sub1 n)))))])
   (test (quicksort s <) mergesort s <))
 
+(test 3 (rec f (λ (x) 3)) 3)
+(test 3 (rec f (λ (x) x)) 3)
+(test 2 (rec f (λ (x) (if (= x 3) (f 2) x))) 3)
+(test 3 (rec (f x) 3) 3)
+(test 3 (rec (f x) x) 3)
+(test 2 (rec (f x) (if (= x 3) (f 2) x)) 3)
+(test 2 (rec (f x . y) (car y)) 1 2 3)
+(test (list 2) (rec (f . x) (if (= (car x) 3) (f 2) x)) 3)
+
 (report-errs)