mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Fix SRFI-2 (and-let*) implementation.

Browse source 
* module/ice-9/and-let-star.scm (%and-let*): Re-implemented this in a
  more verbose but accurate way.
This commit is contained in:
Taylan Ulrich Bayırlı/Kammer 2015-10-02 22:56:04 +02:00 • committed by Andy Wingo
parent 4e27e3c054
commit 8ffcd28fde
1 changed files with 39 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

52
module/ice-9/and-let-star.scm
View file

@ -1,6 +1,7 @@
;;;; and-let-star.scm --- and-let* syntactic form (SRFI-2) for Guile ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -22,20 +23,45 @@
(define-syntax %and-let* (define-syntax %and-let*
(lambda (form) (lambda (form)
(syntax-case form () (syntax-case form ()
((_ orig-form ())
#'#t) ;; Handle zero-clauses special-case.
((_ orig-form () body bodies ...) ((_ orig-form () . body)
#'(begin body bodies ...)) #'(begin #t . body))
((_ orig-form ((var exp) c ...) body ...)
;; Reduce clauses down to one regardless of body.
((_ orig-form ((var expr) rest . rest*) . body)
(identifier? #'var) (identifier? #'var)
#'(let ((var exp)) #'(let ((var expr))
(and var (%and-let* orig-form (c ...) body ...)))) (and var (%and-let* orig-form (rest . rest*) . body))))
((_ orig-form ((exp) c ...) body ...) ((_ orig-form ((expr) rest . rest*) . body)
#'(and exp (%and-let* orig-form (c ...) body ...))) #'(and expr (%and-let* orig-form (rest . rest*) . body)))
((_ orig-form (var c ...) body ...) ((_ orig-form (var rest . rest*) . body)
(identifier? #'var) (identifier? #'var)
#'(and var (%and-let* orig-form (c ...) body ...))) #'(and var (%and-let* orig-form (rest . rest*) . body)))
((_ orig-form (bad-clause c ...) body ...)
;; Handle 1-clause cases without a body.
((_ orig-form ((var expr)))
(identifier? #'var)
#'expr)
((_ orig-form ((expr)))
#'expr)
((_ orig-form (var))
(identifier? #'var)
#'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))))) (syntax-violation 'and-let* "Bad clause" #'orig-form #'bad-clause)))))
(define-syntax and-let* (define-syntax and-let*