| 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 | ;;; 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) |