← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/tagbody.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/tagbody.lsp
 
1
;-*- Mode:     Lisp -*-
 
2
;;;; Author:   Paul Dietz
 
3
;;;; Created:  Sat Oct 12 13:27:22 2002
 
4
;;;; Contains: Tests of TAGBODY
 
5
 
 
6
(in-package :cl-test)
 
7
 
 
8
(deftest tagbody.1
 
9
  (tagbody)
 
10
  nil)
 
11
 
 
12
(deftest tagbody.2
 
13
  (tagbody 'a)
 
14
  nil)
 
15
 
 
16
(deftest tagbody.3
 
17
  (tagbody (values))
 
18
  nil)
 
19
 
 
20
(deftest tagbody.4
 
21
  (tagbody (values 1 2 3 4 5))
 
22
  nil)
 
23
 
 
24
(deftest tagbody.5
 
25
  (let ((x 0))
 
26
    (values
 
27
     (tagbody
 
28
      (setq x 1)
 
29
      (go a)
 
30
      (setq x 2)
 
31
      a)
 
32
     x))
 
33
  nil 1)
 
34
 
 
35
(deftest tagbody.6
 
36
  (let ((x 0))
 
37
    (tagbody
 
38
     (setq x 1)
 
39
     (go a)
 
40
     b
 
41
     (setq x 2)
 
42
     (go c)
 
43
     a
 
44
     (setq x 3)
 
45
     (go b)
 
46
     c)
 
47
    x)
 
48
  2)
 
49
 
 
50
;;; Macroexpansion occurs after tag determination
 
51
(deftest tagbody.7
 
52
  (let ((x 0))
 
53
    (macrolet ((%m () 'a))
 
54
      (tagbody
 
55
       (tagbody
 
56
        (go a)
 
57
        (%m)
 
58
        (setq x 1))
 
59
       a ))
 
60
    x)
 
61
  0)
 
62
 
 
63
(deftest tagbody.8
 
64
  (let ((x 0))
 
65
    (tagbody
 
66
     (flet ((%f (y) (setq x y) (go a)))
 
67
       (%f 10))
 
68
     (setq x 1)
 
69
     a)
 
70
    x)
 
71
  10)
 
72
 
 
73
;;; Tag names are in their own name space
 
74
(deftest tagbody.9
 
75
  (let (result)
 
76
    (tagbody
 
77
     (flet ((a (x) x))
 
78
       (setq result (a 10))
 
79
       (go a))
 
80
     a)
 
81
    result)
 
82
  10)
 
83
 
 
84
(deftest tagbody.10
 
85
  (let (result)
 
86
    (tagbody
 
87
     (block a
 
88
       (setq result 10)
 
89
       (go a))
 
90
     (setq result 20)
 
91
     a)
 
92
    result)
 
93
  10)
 
94
 
 
95
(deftest tagbody.11
 
96
  (let (result)
 
97
    (tagbody
 
98
     (catch 'a
 
99
       (setq result 10)
 
100
       (go a))
 
101
     (setq result 20)
 
102
     a)
 
103
    result)
 
104
  10)
 
105
 
 
106
(deftest tagbody.12
 
107
  (let (result)
 
108
    (tagbody
 
109
     (block a
 
110
       (setq result 10)
 
111
       (return-from a nil))
 
112
     (setq result 20)
 
113
     a)
 
114
    result)
 
115
  20)
 
116
 
 
117
;;; Test that integers are accepted as go tags
 
118
 
 
119
(deftest tagbody.13
 
120
  (block done
 
121
    (tagbody
 
122
     (go around)
 
123
     10
 
124
     (return-from done 'good)
 
125
     around
 
126
     (go 10)))
 
127
  good)
 
128
 
 
129
(deftest tagbody.14
 
130
  (block done
 
131
    (tagbody
 
132
     (go around)
 
133
     -10
 
134
     (return-from done 'good)
 
135
     around
 
136
     (go -10)))
 
137
  good)
 
138
 
 
139
(deftest tagbody.15
 
140
  (block done
 
141
    (tagbody
 
142
     (go around)
 
143
     #.(1+ most-positive-fixnum)
 
144
     (return-from done 'good)
 
145
     around
 
146
     (go #.(1+ most-positive-fixnum))))
 
147
  good)
 
148
 
 
149
(deftest tagbody.16
 
150
  (let* ((t1 (1+ most-positive-fixnum))
 
151
         (t2 (1+ most-positive-fixnum))
 
152
         (form `(block done
 
153
                  (tagbody
 
154
                   (go around)
 
155
                   ,t1
 
156
                   (return-from done 'good)
 
157
                   around
 
158
                   (go ,t2)))))
 
159
    (eval form))
 
160
  good)
 
161
 
 
162
;;; Check that macros are not expanded before finding tags
 
163
;;; Test for issue TAGBODY-TAG-EXPANSION
 
164
(deftest tagbody.17
 
165
  (block done
 
166
    (tagbody
 
167
     (macrolet ((foo () 'tag))
 
168
       (let (tag)
 
169
         (tagbody
 
170
          (go tag)
 
171
          (foo)
 
172
          (return-from done :bad))))
 
173
     tag
 
174
     (return-from done :good)))
 
175
  :good)
 
176
 
 
177