Adapt visit-prompt-control-flow to use intsets.

[bpt/guile.git] / module / ice-9 / and-let-star.scm

diff --git a/module/ice-9/and-let-star.scm b/module/ice-9/and-let-star.scm
index b8cb2a6..ff15a7a 100644 (file)
--- a/module/ice-9/and-let-star.scm
+++ b/module/ice-9/and-let-star.scm
@@ -1,12 +1,11 @@
-;;;; and-let-star.scm --- and-let* syntactic form (draft SRFI-2) for Guile
-;;;; written by Michael Livshin <mike@olan.com>
+;;;; and-let-star.scm --- and-let* syntactic form (SRFI-2) for Guile
 ;;;;
-;;;;   Copyright (C) 1999, 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2004, 2006, 2013 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
 ;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later version.
+;;;; version 3 of the License, or (at your option) any later version.
 ;;;; 
 ;;;; This library is distributed in the hope that it will be useful,
 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -20,30 +19,29 @@
 (define-module (ice-9 and-let-star)
   :export-syntax (and-let*))
 
-(defmacro and-let* (vars . body)
+(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 ...)
+       (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 ...)
+       (identifier? #'var)
+       #'(and var (%and-let* orig-form (c ...) body ...)))
+      ((_ orig-form (bad-clause c ...) body ...)
+       (syntax-violation 'and-let* "Bad clause" #'orig-form #'bad-clause)))))
 
-  (define (expand vars body)
-    (cond
-     ((null? vars)
-      (if (null? body)
-         #t
-         `(begin ,@body)))
-     ((pair? vars)
-      (let ((exp (car vars)))
-        (cond
-         ((pair? exp)
-          (cond
-           ((null? (cdr exp))
-            `(and ,(car exp) ,(expand (cdr vars) body)))
-           (else
-            (let ((var (car exp)))
-              `(let (,exp)
-                 (and ,var ,(expand (cdr vars) body)))))))
-         (else
-          `(and ,exp ,(expand (cdr vars) body))))))
-     (else
-      (error "not a proper list" vars))))
-
-  (expand vars body))
+(define-syntax and-let*
+  (lambda (form)
+    (syntax-case form ()
+      ((_ (c ...) body ...)
+       #`(%and-let* #,form (c ...) body ...)))))
 
 (cond-expand-provide (current-module) '(srfi-2))