Commit | Line | Data |
---|---|---|
bf9eb54a MW |
1 | ;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*- |
2 | ;;;; | |
6dce942c | 3 | ;;;; Copyright (C) 2012, 2013 Free Software Foundation, Inc. |
bf9eb54a MW |
4 | ;;;; |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | (define-module (test-srfi-105) | |
20 | #:use-module (test-suite lib) | |
21 | #:use-module (srfi srfi-1)) | |
22 | ||
23 | (define (read-string s) | |
6dce942c | 24 | (with-input-from-string s read)) |
bf9eb54a MW |
25 | |
26 | (define (with-read-options opts thunk) | |
27 | (let ((saved-options (read-options))) | |
28 | (dynamic-wind | |
29 | (lambda () | |
30 | (read-options opts)) | |
31 | thunk | |
32 | (lambda () | |
33 | (read-options saved-options))))) | |
34 | ||
35 | ;; Verify that curly braces are allowed in identifiers and that neoteric | |
36 | ;; expressions are not recognized by default. | |
37 | (with-test-prefix "no-curly-infix" | |
38 | (pass-if (equal? '({f(x) + g[y] + h{z} + [a]}) | |
39 | `(,(string->symbol "{f") | |
40 | (x) + g [y] + | |
41 | ,(string->symbol "h{z}") | |
42 | + [a] | |
43 | ,(string->symbol "}"))))) | |
44 | ||
45 | #!curly-infix | |
46 | ||
47 | (with-test-prefix "curly-infix" | |
48 | (pass-if (equal? '{n <= 5} '(<= n 5))) | |
49 | (pass-if (equal? '{x + 1} '(+ x 1))) | |
50 | (pass-if (equal? '{a + b + c} '(+ a b c))) | |
51 | (pass-if (equal? '{x ,op y ,op z} '(,op x y z))) | |
52 | (pass-if (equal? '{x eqv? `a} '(eqv? x `a))) | |
53 | (pass-if (equal? '{'a eq? b} '(eq? 'a b))) | |
54 | (pass-if (equal? '{n-1 + n-2} '(+ n-1 n-2))) | |
55 | (pass-if (equal? '{a * {b + c}} '(* a (+ b c)))) | |
56 | (pass-if (equal? '{a + {b - c}} '(+ a (- b c)))) | |
57 | (pass-if (equal? '{{a + b} - c} '(- (+ a b) c))) | |
58 | (pass-if (equal? '{{a > 0} and {b >= 1}} '(and (> a 0) (>= b 1)))) | |
59 | (pass-if (equal? '{} '())) | |
60 | (pass-if (equal? '{5} '5)) | |
61 | (pass-if (equal? '{- x} '(- x))) | |
62 | (pass-if (equal? '{length(x) >= 6} '(>= (length x) 6))) | |
63 | (pass-if (equal? '{f(x) + g(y) + h(z)} '(+ (f x) (g y) (h z)))) | |
64 | (pass-if (equal? '{(f a b) + (g h)} '(+ (f a b) (g h)))) | |
65 | (pass-if (equal? '{f(a b) + g(h)} '(+ (f a b) (g h)))) | |
8d500058 | 66 | (pass-if (equal? ''{a + f(b) + x} ''(+ a (f b) x))) |
bf9eb54a MW |
67 | (pass-if (equal? '{(- a) / b} '(/ (- a) b))) |
68 | (pass-if (equal? '{-(a) / b} '(/ (- a) b))) | |
69 | (pass-if (equal? '{cos(q)} '(cos q))) | |
70 | (pass-if (equal? '{e{}} '(e))) | |
71 | (pass-if (equal? '{pi{}} '(pi))) | |
72 | (pass-if (equal? '{'f(x)} '(quote (f x)))) | |
73 | ||
74 | (pass-if (equal? '{ (f (g h(x))) } '(f (g (h x))))) | |
75 | (pass-if (equal? '{#(1 2 f(a) 4)} '#(1 2 (f a) 4))) | |
76 | (pass-if (equal? '{ (f #;g(x) h(x)) } '(f (h x)))) | |
77 | (pass-if (equal? '{ (f #; g(x)[y] h(x)) } '(f (h x)))) | |
78 | (pass-if (equal? '{ (f #; g[x]{y} h(x)) } '(f (h x)))) | |
79 | ||
80 | (pass-if (equal? '{ (f #(g h(x))) } '(f #(g (h x))))) | |
81 | (pass-if (equal? '{ (f '(g h(x))) } '(f '(g (h x))))) | |
82 | (pass-if (equal? '{ (f `(g h(x))) } '(f `(g (h x))))) | |
83 | (pass-if (equal? '{ (f #'(g h(x))) } '(f #'(g (h x))))) | |
84 | (pass-if (equal? '{ (f #2((g) (h(x)))) } '(f #2((g) ((h x)))))) | |
85 | ||
86 | (pass-if (equal? '{(map - ns)} '(map - ns))) | |
87 | (pass-if (equal? '{map(- ns)} '(map - ns))) | |
88 | (pass-if (equal? '{n * factorial{n - 1}} '(* n (factorial (- n 1))))) | |
89 | (pass-if (equal? '{2 * sin{- x}} '(* 2 (sin (- x))))) | |
90 | ||
91 | (pass-if (equal? '{3 + 4 +} '($nfx$ 3 + 4 +))) | |
92 | (pass-if (equal? '{3 + 4 + 5 +} '($nfx$ 3 + 4 + 5 +))) | |
93 | (pass-if (equal? '{a . z} '($nfx$ a . z))) | |
94 | (pass-if (equal? '{a + b - c} '($nfx$ a + b - c))) | |
95 | ||
96 | (pass-if (equal? '{read(. options)} '(read . options))) | |
97 | ||
98 | (pass-if (equal? '{a(x)(y)} '((a x) y))) | |
99 | (pass-if (equal? '{x[a]} '($bracket-apply$ x a))) | |
100 | (pass-if (equal? '{y[a b]} '($bracket-apply$ y a b))) | |
101 | ||
102 | (pass-if (equal? '{f(g(x))} '(f (g x)))) | |
103 | (pass-if (equal? '{f(g(x) h(x))} '(f (g x) (h x)))) | |
104 | ||
105 | ||
106 | (pass-if (equal? '{} '())) | |
107 | (pass-if (equal? '{e} 'e)) | |
108 | (pass-if (equal? '{e1 e2} '(e1 e2))) | |
109 | ||
110 | (pass-if (equal? '{a . t} '($nfx$ a . t))) | |
111 | (pass-if (equal? '{a b . t} '($nfx$ a b . t))) | |
112 | (pass-if (equal? '{a b c . t} '($nfx$ a b c . t))) | |
113 | (pass-if (equal? '{a b c d . t} '($nfx$ a b c d . t))) | |
114 | (pass-if (equal? '{a + b +} '($nfx$ a + b +))) | |
115 | (pass-if (equal? '{a + b + c +} '($nfx$ a + b + c +))) | |
116 | (pass-if (equal? '{q + r * s} '($nfx$ q + r * s))) | |
117 | ||
118 | ;; The following two tests will become relevant when Guile's reader | |
119 | ;; supports datum labels, specified in SRFI-38 (External | |
120 | ;; Representation for Data With Shared Structure). | |
121 | ||
8d500058 | 122 | ;;(pass-if (equal? '{#1=f(#1#)} '#1=(f #1#))) |
bf9eb54a MW |
123 | ;;(pass-if (equal? '#1={a + . #1#} '($nfx$ . #1=(a + . #1#)))) |
124 | ||
125 | (pass-if (equal? '{e()} '(e))) | |
126 | (pass-if (equal? '{e{}} '(e))) | |
127 | (pass-if (equal? '{e(1)} '(e 1))) | |
128 | (pass-if (equal? '{e{1}} '(e 1))) | |
129 | (pass-if (equal? '{e(1 2)} '(e 1 2))) | |
130 | (pass-if (equal? '{e{1 2}} '(e (1 2)))) | |
131 | (pass-if (equal? '{f{n - 1}} '(f (- n 1)))) | |
132 | (pass-if (equal? '{f{n - 1}(x)} '((f (- n 1)) x))) | |
133 | (pass-if (equal? '{f{n - 1}{y - 1}} '((f (- n 1)) (- y 1)))) | |
134 | (pass-if (equal? '{f{- x}[y]} '($bracket-apply$ (f (- x)) y))) | |
135 | (pass-if (equal? '{g{- x}} '(g (- x)))) | |
136 | (pass-if (equal? '{( . e)} 'e)) | |
137 | ||
138 | (pass-if (equal? '{e[]} '($bracket-apply$ e))) | |
139 | (pass-if (equal? '{e[1 2]} '($bracket-apply$ e 1 2))) | |
140 | (pass-if (equal? '{e[1 . 2]} '($bracket-apply$ e 1 . 2))) | |
141 | ||
142 | ;; Verify that source position information is not recorded if not | |
143 | ;; asked for. | |
144 | (with-test-prefix "no positions" | |
145 | (pass-if "simple curly-infix list" | |
146 | (let ((sexp (with-read-options '(curly-infix) | |
147 | (lambda () | |
148 | (read-string " {1 + 2 + 3}"))))) | |
149 | (and (not (source-property sexp 'line)) | |
150 | (not (source-property sexp 'column))))) | |
151 | (pass-if "mixed curly-infix list" | |
152 | (let ((sexp (with-read-options '(curly-infix) | |
153 | (lambda () | |
154 | (read-string " {1 + 2 * 3}"))))) | |
155 | (and (not (source-property sexp 'line)) | |
156 | (not (source-property sexp 'column))))) | |
157 | (pass-if "singleton curly-infix list" | |
158 | (let ((sexp (with-read-options '(curly-infix) | |
159 | (lambda () | |
160 | (read-string " { 1.0 }"))))) | |
161 | (and (not (source-property sexp 'line)) | |
162 | (not (source-property sexp 'column))))) | |
163 | (pass-if "neoteric expression" | |
164 | (let ((sexp (with-read-options '(curly-infix) | |
165 | (lambda () | |
166 | (read-string " { f(x) }"))))) | |
167 | (and (not (source-property sexp 'line)) | |
168 | (not (source-property sexp 'column)))))) | |
169 | ||
170 | ;; Verify that source position information is properly recorded. | |
171 | (with-test-prefix "positions" | |
172 | (pass-if "simple curly-infix list" | |
173 | (let ((sexp (with-read-options '(curly-infix positions) | |
174 | (lambda () | |
175 | (read-string " {1 + 2 + 3}"))))) | |
176 | (and (equal? (source-property sexp 'line) 0) | |
177 | (equal? (source-property sexp 'column) 1)))) | |
178 | (pass-if "mixed curly-infix list" | |
179 | (let ((sexp (with-read-options '(curly-infix positions) | |
180 | (lambda () | |
181 | (read-string " {1 + 2 * 3}"))))) | |
182 | (and (equal? (source-property sexp 'line) 0) | |
183 | (equal? (source-property sexp 'column) 1)))) | |
184 | (pass-if "singleton curly-infix list" | |
185 | (let ((sexp (with-read-options '(curly-infix positions) | |
186 | (lambda () | |
187 | (read-string " { 1.0 }"))))) | |
188 | (and (equal? (source-property sexp 'line) 0) | |
189 | (equal? (source-property sexp 'column) 3)))) | |
190 | (pass-if "neoteric expression" | |
191 | (let ((sexp (with-read-options '(curly-infix positions) | |
192 | (lambda () | |
193 | (read-string " { f(x) }"))))) | |
194 | (and (equal? (source-property sexp 'line) 0) | |
195 | (equal? (source-property sexp 'column) 3))))) | |
196 | ||
197 | ;; Verify that neoteric expressions are recognized only within curly braces. | |
198 | (pass-if (equal? '(a(x)(y)) '(a (x) (y)))) | |
199 | (pass-if (equal? '(x[a]) '(x [a]))) | |
200 | (pass-if (equal? '(y[a b]) '(y [a b]))) | |
201 | (pass-if (equal? '(a f{n - 1}) '(a f (- n 1)))) | |
202 | (pass-if (equal? '(a f{n - 1}(x)) '(a f (- n 1) (x)))) | |
203 | (pass-if (equal? '(a f{n - 1}[x]) '(a f (- n 1) [x]))) | |
204 | (pass-if (equal? '(a f{n - 1}{y - 1}) '(a f (- n 1) (- y 1)))) | |
205 | ||
206 | ;; Verify that bracket lists are not recognized by default. | |
207 | (pass-if (equal? '{[]} '())) | |
208 | (pass-if (equal? '{[a]} '(a))) | |
209 | (pass-if (equal? '{[a b]} '(a b))) | |
210 | (pass-if (equal? '{[a . b]} '(a . b))) | |
211 | (pass-if (equal? '[] '())) | |
212 | (pass-if (equal? '[a] '(a))) | |
213 | (pass-if (equal? '[a b] '(a b))) | |
214 | (pass-if (equal? '[a . b] '(a . b)))) | |
215 | ||
216 | ||
217 | #!curly-infix-and-bracket-lists | |
218 | ||
219 | (with-test-prefix "curly-infix-and-bracket-lists" | |
220 | ;; Verify that these neoteric expressions still work properly | |
221 | ;; when the 'square-brackets' read option is unset (which is done by | |
222 | ;; the '#!curly-infix-and-bracket-lists' reader directive above). | |
223 | (pass-if (equal? '{e[]} '($bracket-apply$ e))) | |
224 | (pass-if (equal? '{e[1 2]} '($bracket-apply$ e 1 2))) | |
225 | (pass-if (equal? '{e[1 . 2]} '($bracket-apply$ e 1 . 2))) | |
226 | ||
227 | ;; The following expressions are not actually part of SRFI-105, but | |
228 | ;; they are handled when the 'curly-infix' read option is set and the | |
229 | ;; 'square-brackets' read option is unset. This is a non-standard | |
230 | ;; extension of SRFI-105, and follows the convention of GNU Kawa. | |
231 | (pass-if (equal? '{[]} '($bracket-list$))) | |
232 | (pass-if (equal? '{[a]} '($bracket-list$ a))) | |
233 | (pass-if (equal? '{[a b]} '($bracket-list$ a b))) | |
234 | (pass-if (equal? '{[a . b]} '($bracket-list$ a . b))) | |
235 | ||
236 | (pass-if (equal? '[] '($bracket-list$))) | |
237 | (pass-if (equal? '[a] '($bracket-list$ a))) | |
238 | (pass-if (equal? '[a b] '($bracket-list$ a b))) | |
239 | (pass-if (equal? '[a . b] '($bracket-list$ a . b)))) |