module/srfi/srfi-11.scm

   1 ;;; srfi-11.scm --- let-values and let*-values
   2
   3 ;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Commentary:
  20
  21 ;; This module exports two syntax forms: let-values and let*-values.
  22 ;;
  23 ;; Sample usage:
  24 ;;
  25 ;;   (let-values (((x y . z) (foo a b))
  26 ;;                ((p q) (bar c)))
  27 ;;     (baz x y z p q))
  28 ;;
  29 ;; This binds `x' and `y' to the first to values returned by `foo',
  30 ;; `z' to the rest of the values from `foo', and `p' and `q' to the
  31 ;; values returned by `bar'.  All of these are available to `baz'.
  32 ;;
  33 ;; let*-values : let-values :: let* : let
  34 ;;
  35 ;; This module is fully documented in the Guile Reference Manual.
  36
  37 ;;; Code:
  38
  39 (define-module (srfi srfi-11)
  40   :export-syntax (let-values let*-values))
  41
  42 (cond-expand-provide (current-module) '(srfi-11))
  43
  44 ;;;;;;;;;;;;;;
  45 ;; let-values
  46 ;;
  47 ;; Current approach is to translate
  48 ;;
  49 ;;   (let-values (((x y . z) (foo a b))
  50 ;;                ((p q) (bar c)))
  51 ;;     (baz x y z p q))
  52 ;;
  53 ;; into
  54 ;;
  55 ;;   (call-with-values (lambda () (foo a b))
  56 ;;     (lambda (<tmp-x> <tmp-y> . <tmp-z>)
  57 ;;       (call-with-values (lambda () (bar c))
  58 ;;         (lambda (<tmp-p> <tmp-q>)
  59 ;;           (let ((x <tmp-x>)
  60 ;;                 (y <tmp-y>)
  61 ;;                 (z <tmp-z>)
  62 ;;                 (p <tmp-p>)
  63 ;;                 (q <tmp-q>))
  64 ;;             (baz x y z p q))))))
  65
  66 ;; We could really use quasisyntax here...
  67 (define-syntax let-values
  68   (lambda (x)
  69     (syntax-case x ()
  70       ((_ ((binds exp)) b0 b1 ...)
  71        (syntax (call-with-values (lambda () exp)
  72                  (lambda binds b0 b1 ...))))
  73       ((_ (clause ...) b0 b1 ...)
  74        (let lp ((clauses (syntax (clause ...)))
  75                 (ids '())
  76                 (tmps '()))
  77          (if (null? clauses)
  78              (with-syntax (((id ...) ids)
  79                            ((tmp ...) tmps))
  80                (syntax (let ((id tmp) ...)
  81                          b0 b1 ...)))
  82              (syntax-case (car clauses) ()
  83                (((var ...) exp)
  84                 (with-syntax (((new-tmp ...) (generate-temporaries
  85                                               (syntax (var ...))))
  86                               ((id ...) ids)
  87                               ((tmp ...) tmps))
  88                   (with-syntax ((inner (lp (cdr clauses)
  89                                            (syntax (var ... id ...))
  90                                            (syntax (new-tmp ... tmp ...)))))
  91                     (syntax (call-with-values (lambda () exp)
  92                               (lambda (new-tmp ...) inner))))))
  93                ((vars exp)
  94                 (with-syntax ((((new-tmp . new-var) ...)
  95                                (let lp ((vars (syntax vars)))
  96                                  (syntax-case vars ()
  97                                    ((id . rest)
  98                                     (acons (syntax id)
  99                                            (car
 100                                             (generate-temporaries (syntax (id))))
 101                                            (lp (syntax rest))))
 102                                    (id (acons (syntax id)
 103                                               (car
 104                                                (generate-temporaries (syntax (id))))
 105                                               '())))))
 106                               ((id ...) ids)
 107                               ((tmp ...) tmps))
 108                   (with-syntax ((inner (lp (cdr clauses)
 109                                            (syntax (new-var ... id ...))
 110                                            (syntax (new-tmp ... tmp ...))))
 111                                 (args (let lp ((tmps (syntax (new-tmp ...))))
 112                                         (syntax-case tmps ()
 113                                           ((id) (syntax id))
 114                                           ((id . rest) (cons (syntax id)
 115                                                              (lp (syntax rest))))))))
 116                     (syntax (call-with-values (lambda () exp)
 117                               (lambda args inner)))))))))))))
 118
 119 ;;;;;;;;;;;;;;
 120 ;; let*-values
 121 ;;
 122 ;; Current approach is to translate
 123 ;;
 124 ;;   (let*-values (((x y z) (foo a b))
 125 ;;                ((p q) (bar c)))
 126 ;;     (baz x y z p q))
 127 ;;
 128 ;; into
 129 ;;
 130 ;;   (call-with-values (lambda () (foo a b))
 131 ;;     (lambda (x y z)
 132 ;;       (call-with-values (lambda (bar c))
 133 ;;         (lambda (p q)
 134 ;;           (baz x y z p q)))))
 135
 136 (define-syntax let*-values
 137   (syntax-rules ()
 138     ((let*-values () body ...)
 139      (let () body ...))
 140     ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
 141      (call-with-values (lambda () binding-1)
 142        (lambda vars-1
 143          (let*-values ((vars-2 binding-2) ...)
 144            body ...))))))
 145
 146 ;;; srfi-11.scm ends here