Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
108 lines (94 sloc) 3.91 KB
; shorten.ss
;
; Copyright (c) 2010 OKUMURA Yuki and Higepon(Taro Minowa)
;
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
; 1. Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
;
; 2. Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in the
; documentation and/or other materials provided with the distribution.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;
#|
Title: Shorten
This library provides a short alias for lambda expression.
The idea come from "Gauche Devlog - Shorter names http://blog.practical-scheme.net/gauche/20100428-shorter-names" by Shiro.
Example:
(start code)
(map (^(x y) (+ x y)) '(1 2 3 4) '(1 2 3 4)) => (map (lambda (x y) (+ x y)) '(1 2 3 4) '(1 2 3 4))
(^a body ...) => (lambda (a) body ...)
(^b body ...) => (lambda (b) body ...)
...
(^z body ...) => (lambda (z) body ...)
(^_ body ...) => (lambda (_) body ...)
(^a* body ...) => (lambda a* body ...)
(^b* body ...) => (lambda b* body ...)
...
(^z* body ...) => (lambda z* body ...)
(^_* body ...) => (lambda _* body ...)
(end code)
library: (shorten)
|#
(library (shorten)
(export ^a ^b ^c ^d ^e ^f ^g ^h ^i ^j ^k ^l ^m ^n ^o ^p ^q ^r ^s ^t ^u ^v ^w ^x ^y ^z ^_ ^
^a* ^b* ^c* ^d* ^e* ^f* ^g* ^h* ^i* ^j* ^k* ^l* ^m* ^n* ^o* ^p* ^q* ^r* ^s* ^t* ^u* ^v* ^w* ^x* ^y* ^z* ^_*)
(import
(only (rnrs) define-syntax lambda syntax-case define let begin with-syntax
...
symbol->string string->symbol string-append cons map cdr syntax
quote quasiquote unquote
datum->syntax)
(for (shorten helper) expand))
(define-syntax ^
(lambda (x)
(syntax-case x ()
[(_ args ...)
#'(lambda args ...)])))
(define-syntax define-^
(lisp-transformer
(lambda (f)
(define (entry name)
(let ((namestr (symbol->string name)))
`(define-syntax ,(string->symbol (string-append "^" namestr))
(lambda (x)
(syntax-case x ()
((k args ...)
(with-syntax ((larg (datum->syntax #'k (quote ,name))))
#'(lambda (larg) args ...))))))))
(let ((l (cdr f)))
(cons 'begin (map entry l))))))
(define-syntax define-^*
(lisp-transformer
(lambda (f)
(define (entry name)
(let ((namestr (symbol->string name)))
`(define-syntax ,(string->symbol (string-append "^" namestr "*"))
(lambda (x)
(syntax-case x ()
((k args ...)
(with-syntax ((larg (datum->syntax #'k (quote ,(string->symbol (string-append (symbol->string name) "*"))))))
#'(lambda larg args ...))))))))
(let ((l (cdr f)))
(cons 'begin (map entry l))))))
(define-^
_ a b c d e f g h i j k l m n o p q r s t u v w x y z)
(define-^*
_ a b c d e f g h i j k l m n o p q r s t u v w x y z)
)
Jump to Line
Something went wrong with that request. Please try again.