mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
118f0c23c4
* test-suite/tests/srfi-105.test ("curly-infix"): For { EXPR }, allow
the source to be at the { rather than at EXPR.
245 lines
11 KiB
Scheme
245 lines
11 KiB
Scheme
;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*-
|
|
;;;;
|
|
;;;; Copyright (C) 2012, 2013 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
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU Lesser General Public
|
|
;;;; License along with this library; if not, write to the Free Software
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
(define-module (test-srfi-105)
|
|
#:use-module (test-suite lib)
|
|
#:use-module (srfi srfi-1))
|
|
|
|
(define (read-string s)
|
|
(with-input-from-string s read))
|
|
|
|
(define (with-read-options opts thunk)
|
|
(let ((saved-options (read-options)))
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(read-options opts))
|
|
thunk
|
|
(lambda ()
|
|
(read-options saved-options)))))
|
|
|
|
;; Verify that curly braces are allowed in identifiers and that neoteric
|
|
;; expressions are not recognized by default.
|
|
(with-test-prefix "no-curly-infix"
|
|
(pass-if (equal? '({f(x) + g[y] + h{z} + [a]})
|
|
`(,(string->symbol "{f")
|
|
(x) + g [y] +
|
|
,(string->symbol "h{z}")
|
|
+ [a]
|
|
,(string->symbol "}")))))
|
|
|
|
#!curly-infix
|
|
|
|
(with-test-prefix "curly-infix"
|
|
(pass-if (equal? '{n <= 5} '(<= n 5)))
|
|
(pass-if (equal? '{x + 1} '(+ x 1)))
|
|
(pass-if (equal? '{a + b + c} '(+ a b c)))
|
|
(pass-if (equal? '{x ,op y ,op z} '(,op x y z)))
|
|
(pass-if (equal? '{x eqv? `a} '(eqv? x `a)))
|
|
(pass-if (equal? '{'a eq? b} '(eq? 'a b)))
|
|
(pass-if (equal? '{n-1 + n-2} '(+ n-1 n-2)))
|
|
(pass-if (equal? '{a * {b + c}} '(* a (+ b c))))
|
|
(pass-if (equal? '{a + {b - c}} '(+ a (- b c))))
|
|
(pass-if (equal? '{{a + b} - c} '(- (+ a b) c)))
|
|
(pass-if (equal? '{{a > 0} and {b >= 1}} '(and (> a 0) (>= b 1))))
|
|
(pass-if (equal? '{} '()))
|
|
(pass-if (equal? '{5} '5))
|
|
(pass-if (equal? '{- x} '(- x)))
|
|
(pass-if (equal? '{length(x) >= 6} '(>= (length x) 6)))
|
|
(pass-if (equal? '{f(x) + g(y) + h(z)} '(+ (f x) (g y) (h z))))
|
|
(pass-if (equal? '{(f a b) + (g h)} '(+ (f a b) (g h))))
|
|
(pass-if (equal? '{f(a b) + g(h)} '(+ (f a b) (g h))))
|
|
(pass-if (equal? ''{a + f(b) + x} ''(+ a (f b) x)))
|
|
(pass-if (equal? '{(- a) / b} '(/ (- a) b)))
|
|
(pass-if (equal? '{-(a) / b} '(/ (- a) b)))
|
|
(pass-if (equal? '{cos(q)} '(cos q)))
|
|
(pass-if (equal? '{e{}} '(e)))
|
|
(pass-if (equal? '{pi{}} '(pi)))
|
|
(pass-if (equal? '{'f(x)} '(quote (f x))))
|
|
|
|
(pass-if (equal? '{ (f (g h(x))) } '(f (g (h x)))))
|
|
(pass-if (equal? '{#(1 2 f(a) 4)} '#(1 2 (f a) 4)))
|
|
(pass-if (equal? '{ (f #;g(x) h(x)) } '(f (h x))))
|
|
(pass-if (equal? '{ (f #; g(x)[y] h(x)) } '(f (h x))))
|
|
(pass-if (equal? '{ (f #; g[x]{y} h(x)) } '(f (h x))))
|
|
|
|
(pass-if (equal? '{ (f #(g h(x))) } '(f #(g (h x)))))
|
|
(pass-if (equal? '{ (f '(g h(x))) } '(f '(g (h x)))))
|
|
(pass-if (equal? '{ (f `(g h(x))) } '(f `(g (h x)))))
|
|
(pass-if (equal? '{ (f #'(g h(x))) } '(f #'(g (h x)))))
|
|
(pass-if (equal? '{ (f #2((g) (h(x)))) } '(f #2((g) ((h x))))))
|
|
|
|
(pass-if (equal? '{(map - ns)} '(map - ns)))
|
|
(pass-if (equal? '{map(- ns)} '(map - ns)))
|
|
(pass-if (equal? '{n * factorial{n - 1}} '(* n (factorial (- n 1)))))
|
|
(pass-if (equal? '{2 * sin{- x}} '(* 2 (sin (- x)))))
|
|
|
|
(pass-if (equal? '{3 + 4 +} '($nfx$ 3 + 4 +)))
|
|
(pass-if (equal? '{3 + 4 + 5 +} '($nfx$ 3 + 4 + 5 +)))
|
|
(pass-if (equal? '{a . z} '($nfx$ a . z)))
|
|
(pass-if (equal? '{a + b - c} '($nfx$ a + b - c)))
|
|
|
|
(pass-if (equal? '{read(. options)} '(read . options)))
|
|
|
|
(pass-if (equal? '{a(x)(y)} '((a x) y)))
|
|
(pass-if (equal? '{x[a]} '($bracket-apply$ x a)))
|
|
(pass-if (equal? '{y[a b]} '($bracket-apply$ y a b)))
|
|
|
|
(pass-if (equal? '{f(g(x))} '(f (g x))))
|
|
(pass-if (equal? '{f(g(x) h(x))} '(f (g x) (h x))))
|
|
|
|
|
|
(pass-if (equal? '{} '()))
|
|
(pass-if (equal? '{e} 'e))
|
|
(pass-if (equal? '{e1 e2} '(e1 e2)))
|
|
|
|
(pass-if (equal? '{a . t} '($nfx$ a . t)))
|
|
(pass-if (equal? '{a b . t} '($nfx$ a b . t)))
|
|
(pass-if (equal? '{a b c . t} '($nfx$ a b c . t)))
|
|
(pass-if (equal? '{a b c d . t} '($nfx$ a b c d . t)))
|
|
(pass-if (equal? '{a + b +} '($nfx$ a + b +)))
|
|
(pass-if (equal? '{a + b + c +} '($nfx$ a + b + c +)))
|
|
(pass-if (equal? '{q + r * s} '($nfx$ q + r * s)))
|
|
|
|
;; The following two tests will become relevant when Guile's reader
|
|
;; supports datum labels, specified in SRFI-38 (External
|
|
;; Representation for Data With Shared Structure).
|
|
|
|
;;(pass-if (equal? '{#1=f(#1#)} '#1=(f #1#)))
|
|
;;(pass-if (equal? '#1={a + . #1#} '($nfx$ . #1=(a + . #1#))))
|
|
|
|
(pass-if (equal? '{e()} '(e)))
|
|
(pass-if (equal? '{e{}} '(e)))
|
|
(pass-if (equal? '{e(1)} '(e 1)))
|
|
(pass-if (equal? '{e{1}} '(e 1)))
|
|
(pass-if (equal? '{e(1 2)} '(e 1 2)))
|
|
(pass-if (equal? '{e{1 2}} '(e (1 2))))
|
|
(pass-if (equal? '{f{n - 1}} '(f (- n 1))))
|
|
(pass-if (equal? '{f{n - 1}(x)} '((f (- n 1)) x)))
|
|
(pass-if (equal? '{f{n - 1}{y - 1}} '((f (- n 1)) (- y 1))))
|
|
(pass-if (equal? '{f{- x}[y]} '($bracket-apply$ (f (- x)) y)))
|
|
(pass-if (equal? '{g{- x}} '(g (- x))))
|
|
(pass-if (equal? '{( . e)} 'e))
|
|
|
|
(pass-if (equal? '{e[]} '($bracket-apply$ e)))
|
|
(pass-if (equal? '{e[1 2]} '($bracket-apply$ e 1 2)))
|
|
(pass-if (equal? '{e[1 . 2]} '($bracket-apply$ e 1 . 2)))
|
|
|
|
;; Verify that source position information is not recorded if not
|
|
;; asked for.
|
|
(with-test-prefix "no positions"
|
|
(pass-if "simple curly-infix list"
|
|
(let ((sexp (with-read-options '(curly-infix)
|
|
(lambda ()
|
|
(read-string " {1 + 2 + 3}")))))
|
|
(and (not (source-property sexp 'line))
|
|
(not (source-property sexp 'column)))))
|
|
(pass-if "mixed curly-infix list"
|
|
(let ((sexp (with-read-options '(curly-infix)
|
|
(lambda ()
|
|
(read-string " {1 + 2 * 3}")))))
|
|
(and (not (source-property sexp 'line))
|
|
(not (source-property sexp 'column)))))
|
|
(pass-if "singleton curly-infix list"
|
|
(let ((sexp (with-read-options '(curly-infix)
|
|
(lambda ()
|
|
(read-string " { 1.0 }")))))
|
|
(and (not (source-property sexp 'line))
|
|
(not (source-property sexp 'column)))))
|
|
(pass-if "neoteric expression"
|
|
(let ((sexp (with-read-options '(curly-infix)
|
|
(lambda ()
|
|
(read-string " { f(x) }")))))
|
|
(and (not (source-property sexp 'line))
|
|
(not (source-property sexp 'column))))))
|
|
|
|
;; Verify that source position information is properly recorded.
|
|
(with-test-prefix "positions"
|
|
(pass-if "simple curly-infix list"
|
|
(let ((sexp (with-read-options '(curly-infix positions)
|
|
(lambda ()
|
|
(read-string " {1 + 2 + 3}")))))
|
|
(and (equal? (source-property sexp 'line) 0)
|
|
(equal? (source-property sexp 'column) 1))))
|
|
(pass-if "mixed curly-infix list"
|
|
(let ((sexp (with-read-options '(curly-infix positions)
|
|
(lambda ()
|
|
(read-string " {1 + 2 * 3}")))))
|
|
(and (equal? (source-property sexp 'line) 0)
|
|
(equal? (source-property sexp 'column) 1))))
|
|
(pass-if "singleton curly-infix list"
|
|
(let ((sexp (with-read-options '(curly-infix positions)
|
|
(lambda ()
|
|
(read-string " { 1.0 }")))))
|
|
(and (equal? (source-property sexp 'line) 0)
|
|
(case (source-property sexp 'column)
|
|
((1) (throw 'unresolved))
|
|
((3) #t)
|
|
(else #f)))))
|
|
(pass-if "neoteric expression"
|
|
(let ((sexp (with-read-options '(curly-infix positions)
|
|
(lambda ()
|
|
(read-string " { f(x) }")))))
|
|
(and (equal? (source-property sexp 'line) 0)
|
|
(case (source-property sexp 'column)
|
|
((1) (throw 'unresolved))
|
|
((3) #t)
|
|
(else #f))))))
|
|
|
|
;; Verify that neoteric expressions are recognized only within curly braces.
|
|
(pass-if (equal? '(a(x)(y)) '(a (x) (y))))
|
|
(pass-if (equal? '(x[a]) '(x [a])))
|
|
(pass-if (equal? '(y[a b]) '(y [a b])))
|
|
(pass-if (equal? '(a f{n - 1}) '(a f (- n 1))))
|
|
(pass-if (equal? '(a f{n - 1}(x)) '(a f (- n 1) (x))))
|
|
(pass-if (equal? '(a f{n - 1}[x]) '(a f (- n 1) [x])))
|
|
(pass-if (equal? '(a f{n - 1}{y - 1}) '(a f (- n 1) (- y 1))))
|
|
|
|
;; Verify that bracket lists are not recognized by default.
|
|
(pass-if (equal? '{[]} '()))
|
|
(pass-if (equal? '{[a]} '(a)))
|
|
(pass-if (equal? '{[a b]} '(a b)))
|
|
(pass-if (equal? '{[a . b]} '(a . b)))
|
|
(pass-if (equal? '[] '()))
|
|
(pass-if (equal? '[a] '(a)))
|
|
(pass-if (equal? '[a b] '(a b)))
|
|
(pass-if (equal? '[a . b] '(a . b))))
|
|
|
|
|
|
#!curly-infix-and-bracket-lists
|
|
|
|
(with-test-prefix "curly-infix-and-bracket-lists"
|
|
;; Verify that these neoteric expressions still work properly
|
|
;; when the 'square-brackets' read option is unset (which is done by
|
|
;; the '#!curly-infix-and-bracket-lists' reader directive above).
|
|
(pass-if (equal? '{e[]} '($bracket-apply$ e)))
|
|
(pass-if (equal? '{e[1 2]} '($bracket-apply$ e 1 2)))
|
|
(pass-if (equal? '{e[1 . 2]} '($bracket-apply$ e 1 . 2)))
|
|
|
|
;; The following expressions are not actually part of SRFI-105, but
|
|
;; they are handled when the 'curly-infix' read option is set and the
|
|
;; 'square-brackets' read option is unset. This is a non-standard
|
|
;; extension of SRFI-105, and follows the convention of GNU Kawa.
|
|
(pass-if (equal? '{[]} '($bracket-list$)))
|
|
(pass-if (equal? '{[a]} '($bracket-list$ a)))
|
|
(pass-if (equal? '{[a b]} '($bracket-list$ a b)))
|
|
(pass-if (equal? '{[a . b]} '($bracket-list$ a . b)))
|
|
|
|
(pass-if (equal? '[] '($bracket-list$)))
|
|
(pass-if (equal? '[a] '($bracket-list$ a)))
|
|
(pass-if (equal? '[a b] '($bracket-list$ a b)))
|
|
(pass-if (equal? '[a . b] '($bracket-list$ a . b))))
|