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

patched version from Jens (PR7824)

Browse Source 
svn: r2440
This commit is contained in:
Eli Barzilay 2006-03-16 06:31:54 +00:00
parent 6cef2e9230
commit 208a463112
1 changed files with 29 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
collects/srfi/26/cut.ss
View File

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