136 lines
6.6 KiB
Racket
136 lines
6.6 KiB
Racket
;;; cut.rkt
|
|
|
|
; This file reimplements srfi-26 for PLT.
|
|
; The reimplementation provides better error messages.
|
|
|
|
; Examples of errors with better error messages:
|
|
; (cut)
|
|
; ((cut cons <> <>) 1 2 3)
|
|
|
|
#lang scheme/base
|
|
|
|
(provide cut cute)
|
|
(require (for-syntax scheme/base))
|
|
|
|
; 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 occurrences
|
|
; 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 stx names-or-exprs)))))]
|
|
[(cut proc slot-or-expr ... <...>)
|
|
;; Applying a wrong number of arguments to 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.
|
|
|
|
(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)))))]))
|
|
|