From 80c3bb19ce69538275beb7d174278a8e52c10080 Mon Sep 17 00:00:00 2001 From: Noel Welsh Date: Fri, 7 Mar 2008 16:58:45 +0000 Subject: [PATCH] Update SRFI 26 to use the scheme/base language, so it can be used with keyword functions svn: r8920 --- collects/srfi/26.ss | 7 +- collects/srfi/26/cut.ss | 240 ++++++++++++++++++++-------------------- 2 files changed, 124 insertions(+), 123 deletions(-) diff --git a/collects/srfi/26.ss b/collects/srfi/26.ss index fce5a80055..c91d2adcf0 100644 --- a/collects/srfi/26.ss +++ b/collects/srfi/26.ss @@ -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))) diff --git a/collects/srfi/26/cut.ss b/collects/srfi/26/cut.ss index 0631a1f8f4..42d0a3519a 100644 --- a/collects/srfi/26/cut.ss +++ b/collects/srfi/26/cut.ss @@ -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)))))])) - )