As a follow-up to the thread
https://lists.gnu.org/archive/html/guile-devel/2015-06/msg00023.html I
announce that I made an update to the (ice-9 nice-9) module. It no longer
re-exports every, any and count, but instead it replaces two other bindings:
- define-syntax is now blended with define-syntax-rule, so that if one
writes
(define-syntax (name . pattern) . substitution)
the effect will be the same as if she wrote
(define-syntax name (syntax-rules () ((name . pattern) . substitution)))
I think that there's no need to use "define-syntax-rule".
- let-syntax behaves similarly, i.e.
(let-syntax (((name . pattern) replacement)))
....)
transforms to
(let-syntax ((name (syntax-rules () ((name . pattern) replacement)))
....)
Any comments and suggestions are appreciated.
Best regards,
M.
(define-module (ice-9 nice-9)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (every))
#:re-export (match)
#:export ((and-let*/match . and-let*))
#:replace ((cdefine . define)
(mlambda . lambda)
(named-match-let-values . let)
(match-let*-values . let*)
(let-syntax-rules . let-syntax)
(define-syntax/rule . define-syntax)))
(define-syntax define-syntax/rule
(syntax-rules ()
((_ (name . pattern) . transformation)
(define-syntax-rule (name . pattern) . transformation))
((_ name transformer)
(define-syntax name transformer))))
(define-syntax let-syntax-rules
(syntax-rules ()
((_ (bindings ...) body . *)
(letrec-syntax ((let-syntax~
(syntax-rules ()
((_ () ~processed-bindings ~body . ~)
(let-syntax ~processed-bindings ~body . ~))
((_ (((~name ~pattern (... ...)) ~template)
~bindings (... ...))
(~processed (... ...))
~body . ~)
(let-syntax~
(~bindings (... ...))
(~processed (... ...)
(~name (syntax-rules ()
((_ ~pattern (... ...))
~template))))
~body . ~))
((_ ((~name ~value) ~bindings (... ...))
(~processed (... ...)) ~body . ~)
(let-syntax~ (~bindings (... ...))
(~processed (... ...) (~name ~value))
~body . ~)))))
(let-syntax~ (bindings ...) () body . *)))))
(define-syntax mlambda
(lambda (stx)
(syntax-case stx ()
((_ (first-arg ... last-arg . rest-args) body ...)
(and (every identifier? #'(first-arg ... last-arg))
(or (identifier? #'rest-args) (null? #'rest-args)))
#'(lambda (first-arg ... last-arg . rest-args) body ...))
((_ arg body ...)
(or (identifier? #'arg) (null? #'arg))
#'(lambda arg body ...))
((_ args body ...)
#'(match-lambda* (args body ...)))
)))
(define-syntax cdefine
(syntax-rules ()
((_ ((head . tail) . args) body ...)
(cdefine (head . tail)
(mlambda args body ...)))
((_ (name . args) body ...)
(define name (mlambda args body ...)))
((_ . rest)
(define . rest))
))
(define-syntax list<-values
(syntax-rules ()
((_ call)
(call-with-values (lambda () call) list))))
(define-syntax named-match-let-values
(lambda (stx)
(syntax-case stx ()
((_ ((identifier expression) ...) ;; optimization: plain "let" form
body + ...)
(every identifier? #'(identifier ...))
#'(let ((identifier expression) ...)
body + ...))
((_ name ((identifier expression) ...) ;; optimization: regular named-let
body + ...)
(and (identifier? #'name) (every identifier? #'(identifier ...)))
#'(let name ((identifier expression) ...)
body + ...))
((_ name ((structure expression) ...)
body + ...)
(identifier? #'name)
#'(letrec ((name (mlambda (structure ...) body + ...)))
(name expression ...)))
((_ ((structure expression) ...)
body + ...)
#'(match-let ((structure expression) ...)
body + ...))
;; it should generally be discouraged to use the plain let
;; with multiple values, because there's no natural way to implement
;; that when there's more than one (multiple-value) binding,
;; but it's added for completeness
((_ ((structures ... expression) ...)
body + ...)
#'(match-let (((structures ...) (list<-values expression)) ...)
body + ...))
((_ name ((structures ... expression) ...)
body + ...)
(identifier? #'name)
#'(letrec ((loop
(mlambda ((structures ...) ...)
(let-syntax ((name (syntax-rules ()
((_ args (... ...))
(loop (list<-values args)
(... ...))))))
body + ...))))
(loop (list<-values expression) ...)))
)))
(define-syntax match-let*-values
(lambda (stx)
(syntax-case stx ()
((_ ((identifier expression) ...) ;; optimization: regular let*
body + ...)
(every identifier? #'(identifier ...))
#'(let* ((identifier expression) ...)
body + ...))
((_ ((structure expression) ...)
body + ...)
#'(match-let* ((structure expression) ...)
body + ...))
((_ ((identifier expression) remaining-bindings ...)
body + ...)
(identifier? #'identifier)
#'(let ((identifier expression))
(match-let*-values (remaining-bindings ...) body + ...)))
((_ ((structure expression) remaining-bindings ...)
body + ...)
#'(match-let ((structure expression))
(match-let*-values (remaining-bindings ...) body + ...)))
((_ ((structure structures ... expression) remaining-bindings ...)
body + ...)
#'(call-with-values (lambda () expression)
(mlambda (structure structures ...)
(let*-replacement (remaining-bindings ...) body + ...))))
)))
(define-syntax and-let*/match
(lambda (stx)
(syntax-case stx ()
((_)
#'#t)
((_ ())
#'#t)
((_ () body ...)
#'(let () body ...))
((_ ((value binding) rest ...) body ...)
(identifier? #'value)
#'(let ((value binding))
(and value
(and-let*/match (rest ...)
body ...))))
((_ ((value binding) rest ...) body ...)
#'(match binding
(value
(and-let*/match (rest ...)
body ...))
(_ #f)))
((_ ((condition) rest ...)
body ...)
#'(and condition
(and-let*/match (rest ...)
body ...)))
)))
