diff options
author | Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> | 2015-10-02 22:56:04 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2016-06-21 13:40:01 +0200 |
commit | 8ffcd28fde2fab42f1497a33be047f6141bf9b0b (patch) | |
tree | caac9c46b14be1110c7a12b2d9eff62d8cfe13d2 /module | |
parent | 4e27e3c054442189f05355f631176d94b4f5019f (diff) | |
download | guile-8ffcd28fde2fab42f1497a33be047f6141bf9b0b.tar.gz |
Fix SRFI-2 (and-let*) implementation.
* module/ice-9/and-let-star.scm (%and-let*): Re-implemented this in a
more verbose but accurate way.
Diffstat (limited to 'module')
-rw-r--r-- | module/ice-9/and-let-star.scm | 52 |
1 files changed, 39 insertions, 13 deletions
diff --git a/module/ice-9/and-let-star.scm b/module/ice-9/and-let-star.scm index ff15a7a1e..2d53ff384 100644 --- a/module/ice-9/and-let-star.scm +++ b/module/ice-9/and-let-star.scm @@ -1,6 +1,7 @@ ;;;; and-let-star.scm --- and-let* syntactic form (SRFI-2) for Guile ;;;; -;;;; Copyright (C) 1999, 2001, 2004, 2006, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2004, 2006, 2013, +;;;; 2015 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -22,20 +23,45 @@ (define-syntax %and-let* (lambda (form) (syntax-case form () - ((_ orig-form ()) - #'#t) - ((_ orig-form () body bodies ...) - #'(begin body bodies ...)) - ((_ orig-form ((var exp) c ...) body ...) + + ;; Handle zero-clauses special-case. + ((_ orig-form () . body) + #'(begin #t . body)) + + ;; Reduce clauses down to one regardless of body. + ((_ orig-form ((var expr) rest . rest*) . body) + (identifier? #'var) + #'(let ((var expr)) + (and var (%and-let* orig-form (rest . rest*) . body)))) + ((_ orig-form ((expr) rest . rest*) . body) + #'(and expr (%and-let* orig-form (rest . rest*) . body))) + ((_ orig-form (var rest . rest*) . body) + (identifier? #'var) + #'(and var (%and-let* orig-form (rest . rest*) . body))) + + ;; Handle 1-clause cases without a body. + ((_ orig-form ((var expr))) (identifier? #'var) - #'(let ((var exp)) - (and var (%and-let* orig-form (c ...) body ...)))) - ((_ orig-form ((exp) c ...) body ...) - #'(and exp (%and-let* orig-form (c ...) body ...))) - ((_ orig-form (var c ...) body ...) + #'expr) + ((_ orig-form ((expr))) + #'expr) + ((_ orig-form (var)) (identifier? #'var) - #'(and var (%and-let* orig-form (c ...) body ...))) - ((_ orig-form (bad-clause c ...) body ...) + #'var) + + ;; Handle 1-clause cases with a body. + ((_ orig-form ((var expr)) . body) + (identifier? #'var) + #'(let ((var expr)) + (and var (begin . body)))) + ((_ orig-form ((expr)) . body) + #'(and expr (begin . body))) + ((_ orig-form (var) . body) + (identifier? #'var) + #'(and var (begin . body))) + + ;; Handle bad clauses. + ((_ orig-form (bad-clause . rest) . body) (syntax-violation 'and-let* "Bad clause" #'orig-form #'bad-clause))))) (define-syntax and-let* |