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 program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU General Public License as
   7 ;; published by the Free Software Foundation; either version 2, or
   8 ;; (at your option) any later version.
   9 ;;
  10 ;; This program 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 ;; General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this software; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;; Boston, MA 02111-1307 USA
  19 ;;
  20 ;; As a special exception, the Free Software Foundation gives permission
  21 ;; for additional uses of the text contained in its release of GUILE.
  22 ;;
  23 ;; The exception is that, if you link the GUILE library with other files
  24 ;; to produce an executable, this does not by itself cause the
  25 ;; resulting executable to be covered by the GNU General Public License.
  26 ;; Your use of that executable is in no way restricted on account of
  27 ;; linking the GUILE library code into it.
  28 ;;
  29 ;; This exception does not however invalidate any other reasons why
  30 ;; the executable file might be covered by the GNU General Public License.
  31 ;;
  32 ;; This exception applies only to the code released by the
  33 ;; Free Software Foundation under the name GUILE.  If you copy
  34 ;; code from other Free Software Foundation releases into a copy of
  35 ;; GUILE, as the General Public License permits, the exception does
  36 ;; not apply to the code that you add in this way.  To avoid misleading
  37 ;; anyone as to the status of such modified files, you must delete
  38 ;; this exception notice from them.
  39 ;;
  40 ;; If you write modifications of your own for GUILE, it is your choice
  41 ;; whether to permit this exception to apply to your modifications.
  42 ;; If you do not wish that, delete this exception notice.
  43
  44 ;;; Commentary:
  45
  46 ;; This module exports two syntax forms: let-values and let*-values.
  47 ;;
  48 ;; Sample usage:
  49 ;;
  50 ;;   (let-values (((x y . z) (foo a b))
  51 ;;                ((p q) (bar c)))
  52 ;;     (baz x y z p q))
  53 ;;
  54 ;; This binds `x' and `y' to the first to values returned by `foo',
  55 ;; `z' to the rest of the values from `foo', and `p' and `q' to the
  56 ;; values returned by `bar'.  All of these are available to `baz'.
  57 ;;
  58 ;; let*-values : let-values :: let* : let
  59 ;;
  60 ;; This module is fully documented in the Guile Reference Manual.
  61
  62 ;;; Code:
  63
  64 (define-module (srfi srfi-11)
  65   :use-module (ice-9 syncase)
  66   :export-syntax (let-values let*-values))
  67
  68 (cond-expand-provide (current-module) '(srfi-11))
  69
  70 ;;;;;;;;;;;;;;
  71 ;; let-values
  72 ;;
  73 ;; Current approach is to translate
  74 ;;
  75 ;;   (let-values (((x y . z) (foo a b))
  76 ;;                ((p q) (bar c)))
  77 ;;     (baz x y z p q))
  78 ;;
  79 ;; into
  80 ;;
  81 ;;   (call-with-values (lambda () (foo a b))
  82 ;;     (lambda (<tmp-x> <tmp-y> . <tmp-z>)
  83 ;;       (call-with-values (lambda () (bar c))
  84 ;;         (lambda (<tmp-p> <tmp-q>)
  85 ;;           (let ((x <tmp-x>)
  86 ;;                 (y <tmp-y>)
  87 ;;                 (z <tmp-z>)
  88 ;;                 (p <tmp-p>)
  89 ;;                 (q <tmp-q>))
  90 ;;             (baz x y z p q))))))
  91
  92 ;; I originally wrote this as a define-macro, but then I found out
  93 ;; that guile's gensym/gentemp was broken, so I tried rewriting it as
  94 ;; a syntax-rules statement.
  95 ;;
  96 ;; Since syntax-rules didn't seem powerful enough to implement
  97 ;; let-values in one definition without exposing illegal syntax (or
  98 ;; perhaps my brain's just not powerful enough :>).  I tried writing
  99 ;; it using a private helper, but that didn't work because the
 100 ;; let-values expands outside the scope of this module.  I wonder why
 101 ;; syntax-rules wasn't designed to allow "private" patterns or
 102 ;; similar...
 103 ;;
 104 ;; So in the end, I dumped the syntax-rules implementation, reproduced
 105 ;; here for posterity, and went with the define-macro one below --
 106 ;; gensym/gentemp's got to be fixed anyhow...
 107 ;
 108 ; (define-syntax let-values-helper
 109 ;   (syntax-rules ()
 110 ;     ;; Take the vars from one let binding (i.e. the (x y z) from ((x y
 111 ;     ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda
 112 ;     ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the
 113 ;     ;; temps you create so you can use them later...
 114 ;     ;;
 115 ;     ;; I really don't fully understand why the (var-1 var-1) trick
 116 ;     ;; works below, but basically, when all those (x x) bindings show
 117 ;     ;; up in the final "let", syntax-rules forces a renaming.
 118
 119 ;     ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings
 120 ;         body ...)
 121 ;      (lambda lambda-tmps
 122 ;        (let-values-helper "cwv" lv-bindings final-let-bindings body ...)))
 123
 124 ;     ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings
 125 ;         body ...)
 126 ;      (let-values-helper "consumer"
 127 ;                         (var-2 ...)
 128 ;                         (lambda-tmp ... var-1)
 129 ;                         ((var-1 var-1) . final-let-bindings)
 130 ;                         lv-bindings
 131 ;                         body ...))
 132
 133 ;     ((_ "cwv" () final-let-bindings body ...)
 134 ;      (let final-let-bindings
 135 ;          body ...))
 136
 137 ;     ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings
 138 ;         body ...)
 139 ;      (call-with-values (lambda () binding-1)
 140 ;        (let-values-helper "consumer"
 141 ;                           vars-1
 142 ;                           ()
 143 ;                           final-let-bindings
 144 ;                           (other-bindings ...)
 145 ;                           body ...)))))
 146 ;
 147 ; (define-syntax let-values
 148 ;   (syntax-rules ()
 149 ;     ((let-values () body ...)
 150 ;      (begin body ...))
 151 ;     ((let-values (binding ...) body ...)
 152 ;      (let-values-helper "cwv" (binding ...) () body ...))))
 153 ;
 154 ;
 155 ; (define-syntax let-values
 156 ;   (letrec-syntax ((build-consumer
 157 ;                    ;; Take the vars from one let binding (i.e. the (x
 158 ;                    ;; y z) from ((x y z) (values 1 2 3)) and turn it
 159 ;                    ;; in to the corresponding (lambda (<tmp-x> <tmp-y>
 160 ;                    ;; <tmp-z>) ...) from above.
 161 ;                    (syntax-rules ()
 162 ;                      ((_ () new-tmps tmp-vars () body ...)
 163 ;                       (lambda new-tmps
 164 ;                         body ...))
 165 ;                      ((_ () new-tmps tmp-vars vars body ...)
 166 ;                       (lambda new-tmps
 167 ;                         (lv-builder vars tmp-vars body ...)))
 168 ;                      ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...)
 169 ;                       (build-consumer (var-2 ...)
 170 ;                                       (tmp-1 . new-tmps)
 171 ;                                       ((var-1 tmp-1) . tmp-vars)
 172 ;                                       bindings
 173 ;                                       body ...))))
 174 ;                   (lv-builder
 175 ;                    (syntax-rules ()
 176 ;                      ((_ () tmp-vars body ...)
 177 ;                       (let tmp-vars
 178 ;                           body ...))
 179 ;                      ((_ ((vars-1 binding-1) (vars-2 binding-2) ...)
 180 ;                          tmp-vars
 181 ;                          body ...)
 182 ;                       (call-with-values (lambda () binding-1)
 183 ;                         (build-consumer vars-1
 184 ;                                         ()
 185 ;                                         tmp-vars
 186 ;                                         ((vars-2 binding-2) ...)
 187 ;                                         body ...))))))
 188 ;
 189 ;     (syntax-rules ()
 190 ;       ((_ () body ...)
 191 ;        (begin body ...))
 192 ;       ((_ ((vars binding) ...) body ...)
 193 ;        (lv-builder ((vars binding) ...) () body ...)))))
 194
 195 ;; FIXME: This is currently somewhat unsafe (b/c gentemp/gensym is
 196 ;; broken -- right now (as of 1.4.1, it doesn't generate unique
 197 ;; symbols)
 198 (define-macro (let-values vars . body)
 199
 200   (define (map-1-dot proc elts)
 201     ;; map over one optionally dotted (a b c . d) list, producing an
 202     ;; optionally dotted result.
 203     (cond
 204      ((null? elts) '())
 205      ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts))))
 206      (else (proc elts))))
 207
 208   (define (undot-list lst)
 209     ;; produce a non-dotted list from a possibly dotted list.
 210     (cond
 211      ((null? lst) '())
 212      ((pair? lst) (cons (car lst) (undot-list (cdr lst))))
 213      (else (list lst))))
 214
 215   (define (let-values-helper vars body prev-let-vars)
 216     (let* ((var-binding (car vars))
 217            (new-tmps (map-1-dot (lambda (sym) (gensym))
 218                                 (car var-binding)))
 219            (let-vars (map (lambda (sym tmp) (list sym tmp))
 220                           (undot-list (car var-binding))
 221                           (undot-list new-tmps))))
 222
 223       (if (null? (cdr vars))
 224           `(call-with-values (lambda () ,(cadr var-binding))
 225              (lambda ,new-tmps
 226                (let ,(apply append let-vars prev-let-vars)
 227                  ,@body)))
 228           `(call-with-values (lambda () ,(cadr var-binding))
 229              (lambda ,new-tmps
 230                ,(let-values-helper (cdr vars) body
 231                                    (cons let-vars prev-let-vars)))))))
 232
 233   (if (null? vars)
 234       `(begin ,@body)
 235       (let-values-helper vars body '())))
 236
 237 ;;;;;;;;;;;;;;
 238 ;; let*-values
 239 ;;
 240 ;; Current approach is to translate
 241 ;;
 242 ;;   (let*-values (((x y z) (foo a b))
 243 ;;                ((p q) (bar c)))
 244 ;;     (baz x y z p q))
 245 ;;
 246 ;; into
 247 ;;
 248 ;;   (call-with-values (lambda () (foo a b))
 249 ;;     (lambda (x y z)
 250 ;;       (call-with-values (lambda (bar c))
 251 ;;         (lambda (p q)
 252 ;;           (baz x y z p q)))))
 253
 254 (define-syntax let*-values
 255   (syntax-rules ()
 256     ((let*-values () body ...)
 257      (begin body ...))
 258     ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
 259      (call-with-values (lambda () binding-1)
 260        (lambda vars-1
 261          (let*-values ((vars-2 binding-2) ...)
 262            body ...))))))
 263
 264 ; Alternate define-macro implementation...
 265 ;
 266 ; (define-macro (let*-values vars . body)
 267 ;   (define (let-values-helper vars body)
 268 ;     (let ((var-binding (car vars)))
 269 ;       (if (null? (cdr vars))
 270 ;           `(call-with-values (lambda () ,(cadr var-binding))
 271 ;              (lambda ,(car var-binding)
 272 ;                ,@body))
 273 ;           `(call-with-values (lambda () ,(cadr var-binding))
 274 ;              (lambda ,(car var-binding)
 275 ;                ,(let-values-helper (cdr vars) body))))))
 276
 277 ;   (if (null? vars)
 278 ;       `(begin ,@body)
 279 ;       (let-values-helper vars body)))
 280
 281 ;;; srfi-11.scm ends here