/[guile]/guile/guile-core/srfi/srfi-11.scm
ViewVC logotype

Diff of /guile/guile-core/srfi/srfi-11.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by mvo, Sun Dec 16 21:58:24 2001 UTC revision 1.8 by ttn, Thu Mar 28 00:12:37 2002 UTC
# Line 1  Line 1 
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
# Line 41  Line 41 
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))
# Line 100  Line 118 
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"
# Line 165  Line 183 
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 ...))
# Line 184  Line 202 
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
# Line 199  Line 217 
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
# Line 209  Line 227 
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 '())))
# Line 242  Line 260 
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)))
# Line 253  Line 271 
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)))

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26