← Back to branch summary

~ubuntu-branches/ubuntu/hardy/sigscheme/hardy-proposed

« back to all changes in this revision

Viewing changes to test/test-continuation.scm

  • Committer: Bazaar Package Importer
  • Author(s): NIIBE Yutaka
  • Date: 2006-05-23 21:46:41 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20060523214641-6ix4gz34wpiehub8
Tags: 0.5.0-2
http://bugs.debian.org/368571
* debian/control (Build-Depends): Added ruby.
  Thanks to Frederik Schueler.  Closes: #368571
* debian/rules (clean): invoke 'distclean' instead of 'clean'.

Show diffs side-by-side

added added

removed removed

Lines of Context:
test/test-continuation.scm
 
1
;;  FileName : test-continuation.scm
 
2
;;  About    : unit test for continuation
 
3
;;
 
4
;;  Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.jp>
 
5
;;
 
6
;;  All rights reserved.
 
7
;;
 
8
;;  Redistribution and use in source and binary forms, with or without
 
9
;;  modification, are permitted provided that the following conditions
 
10
;;  are met:
 
11
;;
 
12
;;  1. Redistributions of source code must retain the above copyright
 
13
;;     notice, this list of conditions and the following disclaimer.
 
14
;;  2. Redistributions in binary form must reproduce the above copyright
 
15
;;     notice, this list of conditions and the following disclaimer in the
 
16
;;     documentation and/or other materials provided with the distribution.
 
17
;;  3. Neither the name of authors nor the names of its contributors
 
18
;;     may be used to endorse or promote products derived from this software
 
19
;;     without specific prior written permission.
 
20
;;
 
21
;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
 
22
;;  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
 
23
;;  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 
24
;;  PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
 
25
;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
 
26
;;  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
 
27
;;  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
 
28
;;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
 
29
;;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
 
30
;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 
31
;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
32
 
 
33
(load "./test/unittest.scm")
 
34
 
 
35
(define call/cc call-with-current-continuation)
 
36
 
 
37
(assert-equal? "call/cc #1" -3  (call-with-current-continuation
 
38
                                 (lambda (exit)
 
39
                                   (for-each (lambda (x)
 
40
                                               (if (negative? x)
 
41
                                                   (exit x)))
 
42
                                             '(54 0 37 -3 245 19))
 
43
                                   #t)))
 
44
 
 
45
(define list-length
 
46
  (lambda (obj)
 
47
    (call-with-current-continuation
 
48
     (lambda (return)
 
49
       (letrec ((re
 
50
                 (lambda (obj1)
 
51
                   (cond ((null? obj1) 0)
 
52
                         ((pair? obj1)
 
53
                          (+ (re (cdr obj1)) 1))
 
54
                         (else
 
55
                          (return #f))))))
 
56
      (re obj))))))
 
57
 
 
58
(assert-equal? "call/cc #2" 4  (list-length '(1 2 3 4)))
 
59
(assert-equal? "call/cc #3" #f (list-length '(a b . c)))
 
60
 
 
61
;; function written in C as proc
 
62
(assert-true   "call/cc #4" (call/cc procedure?))
 
63
 
 
64
;; another continuation as proc
 
65
(assert-true   "call/cc #5" (procedure? (call/cc (lambda (c) (call/cc c)))))
 
66
 
 
67
(assert-equal? "call/cc #6" 'ret-call/cc
 
68
               (call-with-current-continuation
 
69
                (lambda (k)
 
70
                  'ret-call/cc)))
 
71
 
 
72
(assert-equal? "call/cc #7" 'ret-call/cc
 
73
               (call-with-current-continuation
 
74
                (lambda (k)
 
75
                  (k 'ret-call/cc))))
 
76
 
 
77
;; Call an expired continuation. Current SigScheme cause an error due to its
 
78
;; setjmp/longjmp implementation.
 
79
(assert-error  "call/cc #8"
 
80
               (lambda ()
 
81
                 (let ((res (call-with-current-continuation
 
82
                             (lambda (k)
 
83
                               k))))
 
84
                   (if (procedure? res)
 
85
                       (res 'succeeded)
 
86
                       res))))
 
87
 
 
88
;; "6.4 Control features" of R5RS:
 
89
;; The escape procedure accepts the same number of arguments as the
 
90
;; continuation to the original call to call-with-current-continuation.
 
91
;; Except for continuations created by the `call-with-values' procedure, all
 
92
;; continuations take exactly one value.
 
93
(assert-error "call/cc #9"
 
94
              (lambda ()
 
95
                (call-with-current-continuation
 
96
                 (lambda (k)
 
97
                   (k (values 1 2))))))
 
98
 
 
99
(assert-error "call/cc #10"
 
100
              (lambda ()
 
101
                (call-with-current-continuation
 
102
                 (lambda (k)
 
103
                   (k (values))))))
 
104
 
 
105
;; one value is OK
 
106
(assert-equal? "call/cc #11"
 
107
               1
 
108
               (call-with-current-continuation
 
109
                (lambda (k)
 
110
                  (k (values 1)))))
 
111
 
 
112
(total-report)