srfi/srfi-11.scm

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