suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed PR 8210

Browse Source 
svn: r3979
This commit is contained in:
Robby Findler 2006-08-07 13:31:32 +00:00
parent d2f73275c4
commit a582a09d66
3 changed files with 35 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/mzlib/etc.ss
View File

@ -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))]))
;; 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)))]))
;; 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 ()

47
collects/srfi/31/rec.ss
View File

@ -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

9
collects/tests/mzscheme/function.ss
View File

@ -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)