1 |
;;;; srfi-11.scm --- SRFI-11 procedures for Guile |
;;;; srfi-11.scm --- SRFI-11 procedures for Guile |
2 |
|
|
3 |
;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. |
;;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. |
4 |
;;; |
;;; |
5 |
;;; This program is free software; you can redistribute it and/or |
;;; This program is free software; you can redistribute it and/or |
6 |
;;; modify it under the terms of the GNU General Public License as |
;;; modify it under the terms of the GNU General Public License as |
41 |
;;; whether to permit this exception to apply to your modifications. |
;;; whether to permit this exception to apply to your modifications. |
42 |
;;; If you do not wish that, delete this exception notice. |
;;; 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 |
|
;;; Code: |
61 |
|
|
62 |
(define-module (srfi srfi-11) |
(define-module (srfi srfi-11) |
63 |
:use-module (ice-9 syncase) |
:use-module (ice-9 syncase) |
64 |
:export-syntax (let-values let*-values)) |
:export-syntax (let-values let*-values)) |
118 |
; body ...) |
; body ...) |
119 |
; (lambda lambda-tmps |
; (lambda lambda-tmps |
120 |
; (let-values-helper "cwv" lv-bindings final-let-bindings body ...))) |
; (let-values-helper "cwv" lv-bindings final-let-bindings body ...))) |
121 |
|
|
122 |
; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings |
; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings |
123 |
; body ...) |
; body ...) |
124 |
; (let-values-helper "consumer" |
; (let-values-helper "consumer" |
183 |
; tmp-vars |
; tmp-vars |
184 |
; ((vars-2 binding-2) ...) |
; ((vars-2 binding-2) ...) |
185 |
; body ...)))))) |
; body ...)))))) |
186 |
; |
; |
187 |
; (syntax-rules () |
; (syntax-rules () |
188 |
; ((_ () body ...) |
; ((_ () body ...) |
189 |
; (begin body ...)) |
; (begin body ...)) |
202 |
((null? elts) '()) |
((null? elts) '()) |
203 |
((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts)))) |
((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts)))) |
204 |
(else (proc elts)))) |
(else (proc elts)))) |
205 |
|
|
206 |
(define (undot-list lst) |
(define (undot-list lst) |
207 |
;; produce a non-dotted list from a possibly dotted list. |
;; produce a non-dotted list from a possibly dotted list. |
208 |
(cond |
(cond |
217 |
(let-vars (map (lambda (sym tmp) (list sym tmp)) |
(let-vars (map (lambda (sym tmp) (list sym tmp)) |
218 |
(undot-list (car var-binding)) |
(undot-list (car var-binding)) |
219 |
(undot-list new-tmps)))) |
(undot-list new-tmps)))) |
220 |
|
|
221 |
(if (null? (cdr vars)) |
(if (null? (cdr vars)) |
222 |
`(call-with-values (lambda () ,(cadr var-binding)) |
`(call-with-values (lambda () ,(cadr var-binding)) |
223 |
(lambda ,new-tmps |
(lambda ,new-tmps |
227 |
(lambda ,new-tmps |
(lambda ,new-tmps |
228 |
,(let-values-helper (cdr vars) body |
,(let-values-helper (cdr vars) body |
229 |
(cons let-vars prev-let-vars))))))) |
(cons let-vars prev-let-vars))))))) |
230 |
|
|
231 |
(if (null? vars) |
(if (null? vars) |
232 |
`(begin ,@body) |
`(begin ,@body) |
233 |
(let-values-helper vars body '()))) |
(let-values-helper vars body '()))) |
260 |
body ...)))))) |
body ...)))))) |
261 |
|
|
262 |
; Alternate define-macro implementation... |
; Alternate define-macro implementation... |
263 |
; |
; |
264 |
; (define-macro (let*-values vars . body) |
; (define-macro (let*-values vars . body) |
265 |
; (define (let-values-helper vars body) |
; (define (let-values-helper vars body) |
266 |
; (let ((var-binding (car vars))) |
; (let ((var-binding (car vars))) |
271 |
; `(call-with-values (lambda () ,(cadr var-binding)) |
; `(call-with-values (lambda () ,(cadr var-binding)) |
272 |
; (lambda ,(car var-binding) |
; (lambda ,(car var-binding) |
273 |
; ,(let-values-helper (cdr vars) body)))))) |
; ,(let-values-helper (cdr vars) body)))))) |
274 |
|
|
275 |
; (if (null? vars) |
; (if (null? vars) |
276 |
; `(begin ,@body) |
; `(begin ,@body) |
277 |
; (let-values-helper vars body))) |
; (let-values-helper vars body))) |