srfi/srfi-11.scm

   1 ;;; srfi-11.scm --- let-values and let*-values
   2
   3 ;; Copyright (C) 2000, 2001, 2002, 2004, 2006 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 2.1 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   :use-module (ice-9 syncase)
  41   :export-syntax (let-values let*-values))
  42
  43 (cond-expand-provide (current-module) '(srfi-11))
  44
  45 ;;;;;;;;;;;;;;
  46 ;; let-values
  47 ;;
  48 ;; Current approach is to translate
  49 ;;
  50 ;;   (let-values (((x y . z) (foo a b))
  51 ;;                ((p q) (bar c)))
  52 ;;     (baz x y z p q))
  53 ;;
  54 ;; into
  55 ;;
  56 ;;   (call-with-values (lambda () (foo a b))
  57 ;;     (lambda (<tmp-x> <tmp-y> . <tmp-z>)
  58 ;;       (call-with-values (lambda () (bar c))
  59 ;;         (lambda (<tmp-p> <tmp-q>)
  60 ;;           (let ((x <tmp-x>)
  61 ;;                 (y <tmp-y>)
  62 ;;                 (z <tmp-z>)
  63 ;;                 (p <tmp-p>)
  64 ;;                 (q <tmp-q>))
  65 ;;             (baz x y z p q))))))
  66
  67 ;; I originally wrote this as a define-macro, but then I found out
  68 ;; that guile's gensym/gentemp was broken, so I tried rewriting it as
  69 ;; a syntax-rules statement.
  70 ;;     [make-symbol now fixes gensym/gentemp problems.]
  71 ;;
  72 ;; Since syntax-rules didn't seem powerful enough to implement
  73 ;; let-values in one definition without exposing illegal syntax (or
  74 ;; perhaps my brain's just not powerful enough :>).  I tried writing
  75 ;; it using a private helper, but that didn't work because the
  76 ;; let-values expands outside the scope of this module.  I wonder why
  77 ;; syntax-rules wasn't designed to allow "private" patterns or
  78 ;; similar...
  79 ;;
  80 ;; So in the end, I dumped the syntax-rules implementation, reproduced
  81 ;; here for posterity, and went with the define-macro one below --
  82 ;; gensym/gentemp's got to be fixed anyhow...
  83 ;
  84 ; (define-syntax let-values-helper
  85 ;   (syntax-rules ()
  86 ;     ;; Take the vars from one let binding (i.e. the (x y z) from ((x y
  87 ;     ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda
  88 ;     ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the
  89 ;     ;; temps you create so you can use them later...
  90 ;     ;;
  91 ;     ;; I really don't fully understand why the (var-1 var-1) trick
  92 ;     ;; works below, but basically, when all those (x x) bindings show
  93 ;     ;; up in the final "let", syntax-rules forces a renaming.
  94
  95 ;     ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings
  96 ;         body ...)
  97 ;      (lambda lambda-tmps
  98 ;        (let-values-helper "cwv" lv-bindings final-let-bindings body ...)))
  99
 100 ;     ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings
 101 ;         body ...)
 102 ;      (let-values-helper "consumer"
 103 ;                         (var-2 ...)
 104 ;                         (lambda-tmp ... var-1)
 105 ;                         ((var-1 var-1) . final-let-bindings)
 106 ;                         lv-bindings
 107 ;                         body ...))
 108
 109 ;     ((_ "cwv" () final-let-bindings body ...)
 110 ;      (let final-let-bindings
 111 ;          body ...))
 112
 113 ;     ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings
 114 ;         body ...)
 115 ;      (call-with-values (lambda () binding-1)
 116 ;        (let-values-helper "consumer"
 117 ;                           vars-1
 118 ;                           ()
 119 ;                           final-let-bindings
 120 ;                           (other-bindings ...)
 121 ;                           body ...)))))
 122 ;
 123 ; (define-syntax let-values
 124 ;   (syntax-rules ()
 125 ;     ((let-values () body ...)
 126 ;      (begin body ...))
 127 ;     ((let-values (binding ...) body ...)
 128 ;      (let-values-helper "cwv" (binding ...) () body ...))))
 129 ;
 130 ;
 131 ; (define-syntax let-values
 132 ;   (letrec-syntax ((build-consumer
 133 ;                    ;; Take the vars from one let binding (i.e. the (x
 134 ;                    ;; y z) from ((x y z) (values 1 2 3)) and turn it
 135 ;                    ;; in to the corresponding (lambda (<tmp-x> <tmp-y>
 136 ;                    ;; <tmp-z>) ...) from above.
 137 ;                    (syntax-rules ()
 138 ;                      ((_ () new-tmps tmp-vars () body ...)
 139 ;                       (lambda new-tmps
 140 ;                         body ...))
 141 ;                      ((_ () new-tmps tmp-vars vars body ...)
 142 ;                       (lambda new-tmps
 143 ;                         (lv-builder vars tmp-vars body ...)))
 144 ;                      ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...)
 145 ;                       (build-consumer (var-2 ...)
 146 ;                                       (tmp-1 . new-tmps)
 147 ;                                       ((var-1 tmp-1) . tmp-vars)
 148 ;                                       bindings
 149 ;                                       body ...))))
 150 ;                   (lv-builder
 151 ;                    (syntax-rules ()
 152 ;                      ((_ () tmp-vars body ...)
 153 ;                       (let tmp-vars
 154 ;                           body ...))
 155 ;                      ((_ ((vars-1 binding-1) (vars-2 binding-2) ...)
 156 ;                          tmp-vars
 157 ;                          body ...)
 158 ;                       (call-with-values (lambda () binding-1)
 159 ;                         (build-consumer vars-1
 160 ;                                         ()
 161 ;                                         tmp-vars
 162 ;                                         ((vars-2 binding-2) ...)
 163 ;                                         body ...))))))
 164 ;
 165 ;     (syntax-rules ()
 166 ;       ((_ () body ...)
 167 ;        (begin body ...))
 168 ;       ((_ ((vars binding) ...) body ...)
 169 ;        (lv-builder ((vars binding) ...) () body ...)))))
 170
 171 (define-macro (let-values vars . body)
 172
 173   (define (map-1-dot proc elts)
 174     ;; map over one optionally dotted (a b c . d) list, producing an
 175     ;; optionally dotted result.
 176     (cond
 177      ((null? elts) '())
 178      ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts))))
 179      (else (proc elts))))
 180
 181   (define (undot-list lst)
 182     ;; produce a non-dotted list from a possibly dotted list.
 183     (cond
 184      ((null? lst) '())
 185      ((pair? lst) (cons (car lst) (undot-list (cdr lst))))
 186      (else (list lst))))
 187
 188   (define (let-values-helper vars body prev-let-vars)
 189     (let* ((var-binding (car vars))
 190            (new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var"))
 191                                 (car var-binding)))
 192            (let-vars (map (lambda (sym tmp) (list sym tmp))
 193                           (undot-list (car var-binding))
 194                           (undot-list new-tmps))))
 195
 196       (if (null? (cdr vars))
 197           `(call-with-values (lambda () ,(cadr var-binding))
 198              (lambda ,new-tmps
 199                (let ,(apply append let-vars prev-let-vars)
 200                  ,@body)))
 201           `(call-with-values (lambda () ,(cadr var-binding))
 202              (lambda ,new-tmps
 203                ,(let-values-helper (cdr vars) body
 204                                    (cons let-vars prev-let-vars)))))))
 205
 206   (if (null? vars)
 207       `(begin ,@body)
 208       (let-values-helper vars body '())))
 209
 210 ;;;;;;;;;;;;;;
 211 ;; let*-values
 212 ;;
 213 ;; Current approach is to translate
 214 ;;
 215 ;;   (let*-values (((x y z) (foo a b))
 216 ;;                ((p q) (bar c)))
 217 ;;     (baz x y z p q))
 218 ;;
 219 ;; into
 220 ;;
 221 ;;   (call-with-values (lambda () (foo a b))
 222 ;;     (lambda (x y z)
 223 ;;       (call-with-values (lambda (bar c))
 224 ;;         (lambda (p q)
 225 ;;           (baz x y z p q)))))
 226
 227 (define-syntax let*-values
 228   (syntax-rules ()
 229     ((let*-values () body ...)
 230      (begin body ...))
 231     ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
 232      (call-with-values (lambda () binding-1)
 233        (lambda vars-1
 234          (let*-values ((vars-2 binding-2) ...)
 235            body ...))))))
 236
 237 ; Alternate define-macro implementation...
 238 ;
 239 ; (define-macro (let*-values vars . body)
 240 ;   (define (let-values-helper vars body)
 241 ;     (let ((var-binding (car vars)))
 242 ;       (if (null? (cdr vars))
 243 ;           `(call-with-values (lambda () ,(cadr var-binding))
 244 ;              (lambda ,(car var-binding)
 245 ;                ,@body))
 246 ;           `(call-with-values (lambda () ,(cadr var-binding))
 247 ;              (lambda ,(car var-binding)
 248 ;                ,(let-values-helper (cdr vars) body))))))
 249
 250 ;   (if (null? vars)
 251 ;       `(begin ,@body)
 252 ;       (let-values-helper vars body)))
 253
 254 ;;; srfi-11.scm ends here