Commit | Line | Data |
---|---|---|
6be07c52 | 1 | ;;; srfi-11.scm --- let-values and let*-values |
69dab98b | 2 | |
4dcd8499 | 3 | ;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc. |
6be07c52 | 4 | ;; |
73be1d9e MV |
5 | ;; This library is free software; you can redistribute it and/or |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
83ba2d37 | 8 | ;; version 3 of the License, or (at your option) any later version. |
73be1d9e MV |
9 | ;; |
10 | ;; This library is distributed in the hope that it will be useful, | |
6be07c52 TTN |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
73be1d9e MV |
13 | ;; Lesser General Public License for more details. |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
92205699 | 17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
69dab98b | 18 | |
0706ae06 TTN |
19 | ;;; Commentary: |
20 | ||
21 | ;; This module exports two syntax forms: let-values and let*-values. | |
22 | ;; | |
23 | ;; Sample usage: | |
24 | ;; | |
25 | ;; (let-values (((x y . z) (foo a b)) | |
26 | ;; ((p q) (bar c))) | |
27 | ;; (baz x y z p q)) | |
28 | ;; | |
29 | ;; This binds `x' and `y' to the first to values returned by `foo', | |
30 | ;; `z' to the rest of the values from `foo', and `p' and `q' to the | |
31 | ;; values returned by `bar'. All of these are available to `baz'. | |
32 | ;; | |
33 | ;; let*-values : let-values :: let* : let | |
6be07c52 TTN |
34 | ;; |
35 | ;; This module is fully documented in the Guile Reference Manual. | |
0706ae06 TTN |
36 | |
37 | ;;; Code: | |
38 | ||
69dab98b | 39 | (define-module (srfi srfi-11) |
1a179b03 | 40 | :export-syntax (let-values let*-values)) |
69dab98b | 41 | |
1b2f40b9 MG |
42 | (cond-expand-provide (current-module) '(srfi-11)) |
43 | ||
69dab98b RB |
44 | ;;;;;;;;;;;;;; |
45 | ;; let-values | |
46 | ;; | |
47 | ;; Current approach is to translate | |
48 | ;; | |
109c463f | 49 | ;; (let-values (((x y . z) (foo a b)) |
69dab98b RB |
50 | ;; ((p q) (bar c))) |
51 | ;; (baz x y z p q)) | |
52 | ;; | |
53 | ;; into | |
54 | ;; | |
55 | ;; (call-with-values (lambda () (foo a b)) | |
109c463f | 56 | ;; (lambda (<tmp-x> <tmp-y> . <tmp-z>) |
69dab98b RB |
57 | ;; (call-with-values (lambda () (bar c)) |
58 | ;; (lambda (<tmp-p> <tmp-q>) | |
59 | ;; (let ((x <tmp-x>) | |
60 | ;; (y <tmp-y>) | |
61 | ;; (z <tmp-z>) | |
62 | ;; (p <tmp-p>) | |
63 | ;; (q <tmp-q>)) | |
64 | ;; (baz x y z p q)))))) | |
65 | ||
4dcd8499 AW |
66 | ;; We could really use quasisyntax here... |
67 | (define-syntax let-values | |
68 | (lambda (x) | |
69 | (syntax-case x () | |
bca488f1 AW |
70 | ((_ ((binds exp)) b0 b1 ...) |
71 | (syntax (call-with-values (lambda () exp) | |
72 | (lambda binds b0 b1 ...)))) | |
4dcd8499 AW |
73 | ((_ (clause ...) b0 b1 ...) |
74 | (let lp ((clauses (syntax (clause ...))) | |
75 | (ids '()) | |
76 | (tmps '())) | |
77 | (if (null? clauses) | |
78 | (with-syntax (((id ...) ids) | |
79 | ((tmp ...) tmps)) | |
80 | (syntax (let ((id tmp) ...) | |
81 | b0 b1 ...))) | |
82 | (syntax-case (car clauses) () | |
83 | (((var ...) exp) | |
84 | (with-syntax (((new-tmp ...) (generate-temporaries | |
85 | (syntax (var ...)))) | |
86 | ((id ...) ids) | |
87 | ((tmp ...) tmps)) | |
88 | (with-syntax ((inner (lp (cdr clauses) | |
89 | (syntax (var ... id ...)) | |
90 | (syntax (new-tmp ... tmp ...))))) | |
91 | (syntax (call-with-values (lambda () exp) | |
92 | (lambda (new-tmp ...) inner)))))) | |
93 | ((vars exp) | |
94 | (with-syntax ((((new-tmp . new-var) ...) | |
95 | (let lp ((vars (syntax vars))) | |
96 | (syntax-case vars () | |
97 | ((id . rest) | |
98 | (acons (syntax id) | |
99 | (car | |
100 | (generate-temporaries (syntax (id)))) | |
101 | (lp (syntax rest)))) | |
102 | (id (acons (syntax id) | |
103 | (car | |
104 | (generate-temporaries (syntax (id)))) | |
105 | '()))))) | |
106 | ((id ...) ids) | |
107 | ((tmp ...) tmps)) | |
108 | (with-syntax ((inner (lp (cdr clauses) | |
109 | (syntax (new-var ... id ...)) | |
110 | (syntax (new-tmp ... tmp ...)))) | |
111 | (args (let lp ((tmps (syntax (new-tmp ...)))) | |
112 | (syntax-case tmps () | |
113 | ((id) (syntax id)) | |
114 | ((id . rest) (cons (syntax id) | |
115 | (lp (syntax rest)))))))) | |
116 | (syntax (call-with-values (lambda () exp) | |
117 | (lambda args inner))))))))))))) | |
69dab98b RB |
118 | |
119 | ;;;;;;;;;;;;;; | |
120 | ;; let*-values | |
121 | ;; | |
122 | ;; Current approach is to translate | |
123 | ;; | |
124 | ;; (let*-values (((x y z) (foo a b)) | |
125 | ;; ((p q) (bar c))) | |
126 | ;; (baz x y z p q)) | |
127 | ;; | |
128 | ;; into | |
129 | ;; | |
130 | ;; (call-with-values (lambda () (foo a b)) | |
131 | ;; (lambda (x y z) | |
132 | ;; (call-with-values (lambda (bar c)) | |
133 | ;; (lambda (p q) | |
134 | ;; (baz x y z p q))))) | |
135 | ||
136 | (define-syntax let*-values | |
137 | (syntax-rules () | |
138 | ((let*-values () body ...) | |
4dcd8499 | 139 | (let () body ...)) |
69dab98b RB |
140 | ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...) |
141 | (call-with-values (lambda () binding-1) | |
142 | (lambda vars-1 | |
143 | (let*-values ((vars-2 binding-2) ...) | |
144 | body ...)))))) | |
145 | ||
6be07c52 | 146 | ;;; srfi-11.scm ends here |