[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-2-g91956a9

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=91956a94fe6363cf69d574b56397962ec6ef4468

The branch, stable-2.0 has been updated
       via  91956a94fe6363cf69d574b56397962ec6ef4468 (commit)
       via  18e444b40e88cf1969414a1e621adaed27d1dc43 (commit)
      from  6b480ced9c31be3106e675b51afb2dfa4245bd03 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 91956a94fe6363cf69d574b56397962ec6ef4468
Author: Andy Wingo <address@hidden>
Date:   Thu Apr 28 13:08:22 2011 +0200

    allow while as an expression
    
    * module/ice-9/boot-9.scm (while): Specify the return value as #f under
      normal conditions, #t under (break), and arg... under (break arg...).
    * test-suite/tests/syntax.test ("while"): Test.
    * doc/ref/api-control.texi (while do): Document.

commit 18e444b40e88cf1969414a1e621adaed27d1dc43
Author: Andy Wingo <address@hidden>
Date:   Thu Apr 28 12:17:56 2011 +0200

    add reset and shift
    
    * module/ice-9/control.scm (reset, shift): Add implementations of these
      operators from Wolfgang J Moeller, derived from implementations by
      Oleg Kiselyov.
      (reset*, shift*): Procedural variants.
    
    * test-suite/tests/control.test ("shift and reset"): Add tests,
      originally from Oleg Kiselyov.

-----------------------------------------------------------------------

Summary of changes:
 doc/ref/api-control.texi      |   18 +++++++++++++++---
 module/ice-9/boot-9.scm       |   18 +++++++++---------
 module/ice-9/control.scm      |   30 ++++++++++++++++++++++++++++--
 test-suite/tests/control.test |   38 ++++++++++++++++++++++++++++++++++++++
 test-suite/tests/syntax.test  |   17 ++++++++++++-----
 5 files changed, 102 insertions(+), 19 deletions(-)

diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index 1f33c43..1dde8ea 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -266,13 +266,12 @@ Concept of Closure}).
 @deffn syntax while cond body @dots{}
 Run a loop executing the @var{body} forms while @var{cond} is true.
 @var{cond} is tested at the start of each iteration, so if it's
address@hidden the first time then @var{body} is not executed at all.  The
-return value is unspecified.
address@hidden the first time then @var{body} is not executed at all.
 
 Within @code{while}, two extra bindings are provided, they can be used
 from both @var{cond} and @var{body}.
 
address@hidden {Scheme Procedure} break
address@hidden {Scheme Procedure} break break-arg...
 Break out of the @code{while} form.
 @end deffn
 
@@ -281,6 +280,19 @@ Abandon the current iteration, go back to the start and 
test
 @var{cond} again, etc.
 @end deffn
 
+If the loop terminates normally, by the @var{cond} evaluating to
address@hidden, then the @code{while} expression as a whole evaluates to
address@hidden  If it terminates by a call to @code{break} with some number
+of arguments, those arguments are returned from the @code{while}
+expression, as multiple values.  Otherwise if it terminates by a call to
address@hidden with no arguments, then return value is @code{#t}.
+
address@hidden
+(while #f (error "not reached")) @result{} #f
+(while #t (break)) @result{} #t
+(while #f (break 1 2 3)) @result{} 1 2 3
address@hidden example
+
 Each @code{while} form gets its own @code{break} and @code{continue}
 procedures, operating on that @code{while}.  This means when loops are
 nested the outer @code{break} can be used to escape all the way out.
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 84e76bd..401d904 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -2785,13 +2785,11 @@ module '(ice-9 q) '(make-q q-length))}."
               (define-syntax #,(datum->syntax #'while 'break)
                 (lambda (x)
                   (syntax-case x ()
-                    ((_)
-                     #'(abort-to-prompt break-tag))
-                    ((_ . args)
-                     (syntax-violation 'break "too many arguments" x))
+                    ((_ arg (... ...))
+                     #'(abort-to-prompt break-tag arg (... ...)))
                     (_
-                     #'(lambda ()
-                         (abort-to-prompt break-tag))))))
+                     #'(lambda args
+                         (apply abort-to-prompt break-tag args))))))
               (let lp ()
                 (call-with-prompt
                  continue-tag
@@ -2806,10 +2804,12 @@ module '(ice-9 q) '(make-q q-length))}."
                          (_
                           #'(lambda ()
                               (abort-to-prompt continue-tag))))))
-                   (do () ((not cond)) body ...))
+                   (do () ((not cond) #f) body ...))
                  (lambda (k) (lp)))))
-            (lambda (k)
-              #t)))))))
+            (lambda (k . args)
+              (if (null? args)
+                  #t
+                  (apply values args)))))))))
 
 
 
diff --git a/module/ice-9/control.scm b/module/ice-9/control.scm
index dbee61e..908e0e9 100644
--- a/module/ice-9/control.scm
+++ b/module/ice-9/control.scm
@@ -1,6 +1,6 @@
 ;;; Beyond call/cc
 
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011 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
@@ -21,7 +21,7 @@
 (define-module (ice-9 control)
   #:re-export (call-with-prompt abort-to-prompt
                default-prompt-tag make-prompt-tag)
-  #:export (% abort))
+  #:export (% abort shift reset shift* reset*))
 
 (define (abort . args)
   (apply abort-to-prompt (default-prompt-tag) args))
@@ -54,3 +54,29 @@
   (% (default-prompt-tag)
      (proc k)
      default-prompt-handler))
+
+;; Kindly provided by Wolfgang J Moeller <address@hidden>, modelled
+;; after the ones by Oleg Kiselyov in
+;; http://okmij.org/ftp/Scheme/delim-control-n.scm, which are in the
+;; public domain, as noted at the top of http://okmij.org/ftp/.
+;; 
+(define-syntax reset
+  (syntax-rules ()
+    ((_ . body)
+     (call-with-prompt (default-prompt-tag)
+                       (lambda () . body)
+                       (lambda (cont f) (f cont))))))
+
+(define-syntax shift
+  (syntax-rules ()
+    ((_ var . body)
+     (abort-to-prompt (default-prompt-tag)
+                      (lambda (cont)
+                        ((lambda (var) (reset . body))
+                         (lambda vals (reset (apply cont vals)))))))))
+
+(define (reset* thunk)
+  (reset (thunk)))
+
+(define (shift* fc)
+  (shift c (fc c)))
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index 6f1804a..1c30b9c 100644
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -350,3 +350,41 @@
           (and (eq? key 'foo)
                (eq? vm new-vm)
                (eq? (the-vm) prev-vm)))))))
+
+;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
+;; http://okmij.org/ftp/Scheme/delim-control-n.scm.  Public domain.
+;;
+(with-test-prefix "shift and reset"
+  (pass-if (equal?
+            117
+            (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3)))))))))
+
+  (pass-if (equal?
+            60
+            (* 10 (reset (* 2 (shift g (* 5 (shift f (+ (f 1) 1)))))))))
+
+  (pass-if (equal?
+            121
+            (let ((f (lambda (x) (shift k (k (k x))))))
+              (+ 1 (reset (+ 10 (f 100)))))))
+
+  (pass-if (equal?
+            'a
+            (car (reset
+                  (let ((x (shift f
+                                  (shift f1 (f1 (cons 'a (f '())))))))
+                    (shift g x))))))
+  
+  ;; Example by Olivier Danvy
+  (pass-if (equal?
+            '(1 2 3 4 5)
+            (let ()
+              (define (traverse xs)
+                (define (visit xs)
+                  (if (null? xs)
+                      '()
+                      (visit (shift*
+                              (lambda (k)
+                                (cons (car xs) (k (cdr xs))))))))
+                (reset* (lambda () (visit xs))))
+              (traverse '(1 2 3 4 5))))))
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index b33df7c..f6eb28a 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -983,11 +983,18 @@
   
   (with-test-prefix "break"
     
-    (pass-if-syntax-error "too many args" exception:too-many-args
-      (eval '(while #t
-               (break 1))
-            (interaction-environment)))
-    
+    (pass-if "normal return"
+      (not (while #f (error "not reached"))))
+
+    (pass-if "no args"
+      (while #t (break)))
+
+    (pass-if "multiple values"
+      (equal? '(1 2 3)
+              (call-with-values
+                  (lambda () (while #t (break 1 2 3)))
+                list)))
+
     (with-test-prefix "from cond"
       (pass-if "first"
        (while (begin


hooks/post-receive
-- 
GNU Guile