srfi/srfi-11.scm

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