srfi/srfi-11.scm

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