diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 7a03accef3..44ae14f789 100644 --- a/collects/mzlib/etc.ss +++ b/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 - (define-syntax (recur stx) - (syntax-case stx () - [(_ . rest) (syntax/loc stx (let . rest))])) - - ;; define a recursive value - (define-syntax (rec stx) - (syntax-case stx () - [(_ name expr) - (begin (unless (identifier? (syntax name)) - (raise-syntax-error #f "not an identifier" stx (syntax name))) - (syntax/loc stx (letrec ([name expr]) name)))])) + ;; recur is another name for 'let' in a named let + (define-syntax (recur stx) + (syntax-case stx () + [(_ . rest) (syntax/loc stx (let . rest))])) + + ;; define a recursive value + ;; implementation by Jens Axel Soegaard + (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)))] + [(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 () diff --git a/collects/srfi/31/rec.ss b/collects/srfi/31/rec.ss index d7058cbd9a..4ab352ca0d 100644 --- a/collects/srfi/31/rec.ss +++ b/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 diff --git a/collects/tests/mzscheme/function.ss b/collects/tests/mzscheme/function.ss index bdb081abad..4accf21600 100644 --- a/collects/tests/mzscheme/function.ss +++ b/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)