diff options
Diffstat (limited to 'module/srfi/srfi-11.scm')
-rw-r--r-- | module/srfi/srfi-11.scm | 146 |
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 |