← Back to branch summary

~ubuntu-branches/ubuntu/hardy/uim/hardy

« back to all changes in this revision

Viewing changes to sigscheme/test/test-continuation.scm

  • Committer: Bazaar Package Importer
  • Author(s): Masahito Omote
  • Date: 2007-04-21 03:46:09 UTC
  • mfrom: (1.1.6 upstream)
  • Revision ID: james.westby@ubuntu.com-20070421034609-gpcurkutp8vaysqj
Tags: 1:1.4.1-3
* Switch to dh_gtkmodules for the gtk 2.10 transition (Closes:
  #419318)
  - debian/control: Add ${misc:Depends} and remove libgtk2.0-bin on
    uim-gtk2.0.
  - debian/uim-gtk2.0.post{inst,rm}: Removed.

Show diffs side-by-side

added added

removed removed

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