Update SRFI 26 to use the scheme/base language, so it can be used with keyword functions
svn: r8920
This commit is contained in:
Noel Welsh
parent
d71f913097
commit
80c3bb19ce
|
|
@ -1,4 +1,5 @@
|
|||
;; module loader for SRFI-26
|
||||
(module |26| mzscheme
|
||||
(require srfi/26/cut)
|
||||
(provide (all-from srfi/26/cut)))
|
||||
#lang scheme/base
|
||||
|
||||
(require srfi/26/cut)
|
||||
(provide (all-from-out srfi/26/cut)))
|
||||
|
|
|
|||
|
|
@ -7,128 +7,128 @@
|
|||
; (cut)
|
||||
; ((cut cons <> <>) 1 2 3)
|
||||
|
||||
(module cut mzscheme
|
||||
#lang scheme/base
|
||||
|
||||
(provide cut cute)
|
||||
(provide cut cute)
|
||||
|
||||
; generate-names/exprs :
|
||||
; Given the arguments for the macro call to cut (or cute) as a syntax-list,
|
||||
; call build with four lists:
|
||||
; 1) a list of names given to each <>-slot
|
||||
; 2) [cut] a list of the macro arguments, except that all occurences
|
||||
; of a <>-slots have been substituted with the chosen name.
|
||||
; 3) [cute] a list the names given to the exprs and the <>-slots
|
||||
; 4) [cute] a list of lists of name-expression pairs, i.e. the bindings
|
||||
; used to bind the expressions to names, in order to evaluate
|
||||
; the expressions at the time of the macro call to cute.
|
||||
(define-for-syntax (generate-names/exprs slot-or-exprs build)
|
||||
(let loop ([slot-or-exprs (syntax->list slot-or-exprs)]
|
||||
[slot-names '()]
|
||||
[cut-names-or-exprs '()]
|
||||
[cute-names '()]
|
||||
[bindings '()])
|
||||
(cond
|
||||
[(null? slot-or-exprs) (build (reverse slot-names)
|
||||
(reverse cut-names-or-exprs)
|
||||
(reverse cute-names)
|
||||
(reverse bindings))]
|
||||
[else (let ((name (car (generate-temporaries #'(x)))))
|
||||
(syntax-case (car slot-or-exprs) (<> <...>)
|
||||
[<>
|
||||
(loop (cdr slot-or-exprs)
|
||||
(cons name slot-names)
|
||||
(cons name cut-names-or-exprs)
|
||||
(cons name cute-names)
|
||||
bindings)]
|
||||
[_
|
||||
(loop (cdr slot-or-exprs)
|
||||
slot-names
|
||||
(cons (car slot-or-exprs) cut-names-or-exprs)
|
||||
(cons name cute-names)
|
||||
(cons (list name (car slot-or-exprs))
|
||||
bindings))]))])))
|
||||
; generate-names/exprs :
|
||||
; Given the arguments for the macro call to cut (or cute) as a syntax-list,
|
||||
; call build with four lists:
|
||||
; 1) a list of names given to each <>-slot
|
||||
; 2) [cut] a list of the macro arguments, except that all occurences
|
||||
; of a <>-slots have been substituted with the chosen name.
|
||||
; 3) [cute] a list the names given to the exprs and the <>-slots
|
||||
; 4) [cute] a list of lists of name-expression pairs, i.e. the bindings
|
||||
; used to bind the expressions to names, in order to evaluate
|
||||
; the expressions at the time of the macro call to cute.
|
||||
(define-for-syntax (generate-names/exprs slot-or-exprs build)
|
||||
(let loop ([slot-or-exprs (syntax->list slot-or-exprs)]
|
||||
[slot-names '()]
|
||||
[cut-names-or-exprs '()]
|
||||
[cute-names '()]
|
||||
[bindings '()])
|
||||
(cond
|
||||
[(null? slot-or-exprs) (build (reverse slot-names)
|
||||
(reverse cut-names-or-exprs)
|
||||
(reverse cute-names)
|
||||
(reverse bindings))]
|
||||
[else (let ((name (car (generate-temporaries #'(x)))))
|
||||
(syntax-case (car slot-or-exprs) (<> <...>)
|
||||
[<>
|
||||
(loop (cdr slot-or-exprs)
|
||||
(cons name slot-names)
|
||||
(cons name cut-names-or-exprs)
|
||||
(cons name cute-names)
|
||||
bindings)]
|
||||
[_
|
||||
(loop (cdr slot-or-exprs)
|
||||
slot-names
|
||||
(cons (car slot-or-exprs) cut-names-or-exprs)
|
||||
(cons name cute-names)
|
||||
(cons (list name (car slot-or-exprs))
|
||||
bindings))]))])))
|
||||
|
||||
(define-syntax (cut stx)
|
||||
(syntax-case stx (<> <...>)
|
||||
[(cut)
|
||||
(raise-syntax-error #f "cut expects 1 or more slots or expressions, given none" stx)]
|
||||
[(cut <>)
|
||||
#'(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)
|
||||
#'(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 ...)
|
||||
(generate-names/exprs #'(slot-or-expr ...)
|
||||
(lambda (slot-names names-or-exprs . ignored)
|
||||
#`(lambda (x #,@slot-names)
|
||||
(x #,@(datum->syntax-object stx names-or-exprs)))))]
|
||||
[(cut proc slot-or-expr ... <...>)
|
||||
;; 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
|
||||
;; shows the cut-expression as the source of the error in stead of the showing an error in
|
||||
;; the code implementing the macro i.e. in this code.
|
||||
;; 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 ...)
|
||||
(lambda (slot-names names-or-exprs . ignored)
|
||||
#`(lambda (#,@slot-names . xs)
|
||||
#,(quasisyntax/loc stx
|
||||
(apply proc #,@names-or-exprs xs)))))]
|
||||
[(cut proc slot-or-expr ...)
|
||||
(generate-names/exprs #'(slot-or-expr ...)
|
||||
(lambda (slot-names names-or-exprs . ignored)
|
||||
#`(lambda #,slot-names
|
||||
#,(quasisyntax/loc stx
|
||||
(proc #,@names-or-exprs)))))]))
|
||||
(define-syntax (cut stx)
|
||||
(syntax-case stx (<> <...>)
|
||||
[(cut)
|
||||
(raise-syntax-error #f "cut expects 1 or more slots or expressions, given none" stx)]
|
||||
[(cut <>)
|
||||
#'(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)
|
||||
#'(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 ...)
|
||||
(generate-names/exprs #'(slot-or-expr ...)
|
||||
(lambda (slot-names names-or-exprs . ignored)
|
||||
#`(lambda (x #,@slot-names)
|
||||
(x #,@(datum->syntax-object stx names-or-exprs)))))]
|
||||
[(cut proc slot-or-expr ... <...>)
|
||||
;; 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
|
||||
;; shows the cut-expression as the source of the error in stead of the showing an error in
|
||||
;; the code implementing the macro i.e. in this code.
|
||||
;; 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 ...)
|
||||
(lambda (slot-names names-or-exprs . ignored)
|
||||
#`(lambda (#,@slot-names . xs)
|
||||
#,(quasisyntax/loc stx
|
||||
(apply proc #,@names-or-exprs xs)))))]
|
||||
[(cut proc slot-or-expr ...)
|
||||
(generate-names/exprs #'(slot-or-expr ...)
|
||||
(lambda (slot-names names-or-exprs . ignored)
|
||||
#`(lambda #,slot-names
|
||||
#,(quasisyntax/loc stx
|
||||
(proc #,@names-or-exprs)))))]))
|
||||
|
||||
; In addition to cut, there is a variant called cute (a mnemonic for
|
||||
; "cut with evaluated non-slots") which evaluates the non-slot expressions
|
||||
; at the time the procedure is specialized, not at the time the specialized
|
||||
; procedure is called. For example,
|
||||
; (cute cons (+ a 1) <>) is the same as (let ((a1 (+ a 1))) (lambda (x2) (cons a1 x2)))
|
||||
; As you see from comparing this example with the first example above, the
|
||||
; cute-variant will evaluate (+ a 1) once, while the cut-variant will evaluate
|
||||
; it during every invokation of the resulting procedure.
|
||||
; In addition to cut, there is a variant called cute (a mnemonic for
|
||||
; "cut with evaluated non-slots") which evaluates the non-slot expressions
|
||||
; at the time the procedure is specialized, not at the time the specialized
|
||||
; procedure is called. For example,
|
||||
; (cute cons (+ a 1) <>) is the same as (let ((a1 (+ a 1))) (lambda (x2) (cons a1 x2)))
|
||||
; As you see from comparing this example with the first example above, the
|
||||
; cute-variant will evaluate (+ a 1) once, while the cut-variant will evaluate
|
||||
; it during every invokation of the resulting procedure.
|
||||
|
||||
(define-syntax (cute stx)
|
||||
(syntax-case stx (<> <...>)
|
||||
[(cute)
|
||||
(raise-syntax-error #f "cute expects 1 or more slots or expressions, given none" stx)]
|
||||
[(cute <>)
|
||||
#'(lambda (f) (f))]
|
||||
[(cute <...> slot-or-expr ...)
|
||||
(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 ... <...>)
|
||||
(generate-names/exprs #'(slot-or-expr ...)
|
||||
(lambda (slot-names ignored names bindings)
|
||||
#`(let #,bindings
|
||||
(lambda (#,@slot-names . xs)
|
||||
(apply proc #,@names xs)))))]
|
||||
[(cute proc slot-or-expr ...)
|
||||
(generate-names/exprs #'(slot-or-expr ...)
|
||||
(lambda (slot-names ignored names bindings)
|
||||
#`(let #,bindings
|
||||
(lambda #,slot-names
|
||||
(proc #,@names)))))]))
|
||||
|
||||
(define-syntax (cute stx)
|
||||
(syntax-case stx (<> <...>)
|
||||
[(cute)
|
||||
(raise-syntax-error #f "cute expects 1 or more slots or expressions, given none" stx)]
|
||||
[(cute <>)
|
||||
#'(lambda (f) (f))]
|
||||
[(cute <...> slot-or-expr ...)
|
||||
(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 ... <...>)
|
||||
(generate-names/exprs #'(slot-or-expr ...)
|
||||
(lambda (slot-names ignored names bindings)
|
||||
#`(let #,bindings
|
||||
(lambda (#,@slot-names . xs)
|
||||
(apply proc #,@names xs)))))]
|
||||
[(cute proc slot-or-expr ...)
|
||||
(generate-names/exprs #'(slot-or-expr ...)
|
||||
(lambda (slot-names ignored names bindings)
|
||||
#`(let #,bindings
|
||||
(lambda #,slot-names
|
||||
(proc #,@names)))))]))
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user