From 7d484e076e237d6522ca53474fb9d180472a9f54 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?= Date: Fri, 2 Oct 2015 22:56:04 +0200 Subject: [PATCH 1/3] Fix SRFI-2 (and-let*) implementation. --- module/ice-9/and-let-star.scm | 52 ++++++++++++++++++++++++++++++++----------- 1 file changed, 39 insertions(+), 13 deletions(-) diff --git a/module/ice-9/and-let-star.scm b/module/ice-9/and-let-star.scm index ff15a7a..2d53ff3 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* -- 2.5.0