summaryrefslogtreecommitdiff
path: root/module/srfi/srfi-11.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/srfi/srfi-11.scm')
-rw-r--r--module/srfi/srfi-11.scm146
1 files changed, 146 insertions, 0 deletions
diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm
new file mode 100644
index 000000000..22bda21a2
--- /dev/null
+++ b/module/srfi/srfi-11.scm
@@ -0,0 +1,146 @@
+;;; srfi-11.scm --- let-values and let*-values
+
+;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This module exports two syntax forms: let-values and let*-values.
+;;
+;; Sample usage:
+;;
+;; (let-values (((x y . z) (foo a b))
+;; ((p q) (bar c)))
+;; (baz x y z p q))
+;;
+;; This binds `x' and `y' to the first to values returned by `foo',
+;; `z' to the rest of the values from `foo', and `p' and `q' to the
+;; values returned by `bar'. All of these are available to `baz'.
+;;
+;; let*-values : let-values :: let* : let
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-11)
+ :export-syntax (let-values let*-values))
+
+(cond-expand-provide (current-module) '(srfi-11))
+
+;;;;;;;;;;;;;;
+;; let-values
+;;
+;; Current approach is to translate
+;;
+;; (let-values (((x y . z) (foo a b))
+;; ((p q) (bar c)))
+;; (baz x y z p q))
+;;
+;; into
+;;
+;; (call-with-values (lambda () (foo a b))
+;; (lambda (<tmp-x> <tmp-y> . <tmp-z>)
+;; (call-with-values (lambda () (bar c))
+;; (lambda (<tmp-p> <tmp-q>)
+;; (let ((x <tmp-x>)
+;; (y <tmp-y>)
+;; (z <tmp-z>)
+;; (p <tmp-p>)
+;; (q <tmp-q>))
+;; (baz x y z p q))))))
+
+;; We could really use quasisyntax here...
+(define-syntax let-values
+ (lambda (x)
+ (syntax-case x ()
+ ((_ ((binds exp)) b0 b1 ...)
+ (syntax (call-with-values (lambda () exp)
+ (lambda binds b0 b1 ...))))
+ ((_ (clause ...) b0 b1 ...)
+ (let lp ((clauses (syntax (clause ...)))
+ (ids '())
+ (tmps '()))
+ (if (null? clauses)
+ (with-syntax (((id ...) ids)
+ ((tmp ...) tmps))
+ (syntax (let ((id tmp) ...)
+ b0 b1 ...)))
+ (syntax-case (car clauses) ()
+ (((var ...) exp)
+ (with-syntax (((new-tmp ...) (generate-temporaries
+ (syntax (var ...))))
+ ((id ...) ids)
+ ((tmp ...) tmps))
+ (with-syntax ((inner (lp (cdr clauses)
+ (syntax (var ... id ...))
+ (syntax (new-tmp ... tmp ...)))))
+ (syntax (call-with-values (lambda () exp)
+ (lambda (new-tmp ...) inner))))))
+ ((vars exp)
+ (with-syntax ((((new-tmp . new-var) ...)
+ (let lp ((vars (syntax vars)))
+ (syntax-case vars ()
+ ((id . rest)
+ (acons (syntax id)
+ (car
+ (generate-temporaries (syntax (id))))
+ (lp (syntax rest))))
+ (id (acons (syntax id)
+ (car
+ (generate-temporaries (syntax (id))))
+ '())))))
+ ((id ...) ids)
+ ((tmp ...) tmps))
+ (with-syntax ((inner (lp (cdr clauses)
+ (syntax (new-var ... id ...))
+ (syntax (new-tmp ... tmp ...))))
+ (args (let lp ((tmps (syntax (new-tmp ...))))
+ (syntax-case tmps ()
+ ((id) (syntax id))
+ ((id . rest) (cons (syntax id)
+ (lp (syntax rest))))))))
+ (syntax (call-with-values (lambda () exp)
+ (lambda args inner)))))))))))))
+
+;;;;;;;;;;;;;;
+;; let*-values
+;;
+;; Current approach is to translate
+;;
+;; (let*-values (((x y z) (foo a b))
+;; ((p q) (bar c)))
+;; (baz x y z p q))
+;;
+;; into
+;;
+;; (call-with-values (lambda () (foo a b))
+;; (lambda (x y z)
+;; (call-with-values (lambda (bar c))
+;; (lambda (p q)
+;; (baz x y z p q)))))
+
+(define-syntax let*-values
+ (syntax-rules ()
+ ((let*-values () body ...)
+ (let () body ...))
+ ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
+ (call-with-values (lambda () binding-1)
+ (lambda vars-1
+ (let*-values ((vars-2 binding-2) ...)
+ body ...))))))
+
+;;; srfi-11.scm ends here