diff options
Diffstat (limited to 'test-suite/tests')
-rw-r--r-- | test-suite/tests/chars.test | 84 | ||||
-rw-r--r-- | test-suite/tests/list.test | 6 | ||||
-rw-r--r-- | test-suite/tests/numbers.test | 2 | ||||
-rw-r--r-- | test-suite/tests/reader.test | 13 | ||||
-rw-r--r-- | test-suite/tests/regexp.test | 24 | ||||
-rw-r--r-- | test-suite/tests/srfi-105.test | 240 | ||||
-rw-r--r-- | test-suite/tests/srfi-31.test | 7 | ||||
-rw-r--r-- | test-suite/tests/strings.test | 62 | ||||
-rw-r--r-- | test-suite/tests/structs.test | 42 | ||||
-rw-r--r-- | test-suite/tests/texinfo.test | 3 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 82 | ||||
-rw-r--r-- | test-suite/tests/web-uri.test | 4 |
12 files changed, 512 insertions, 57 deletions
diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test index bdc9bdb41..98854f73a 100644 --- a/test-suite/tests/chars.test +++ b/test-suite/tests/chars.test @@ -45,18 +45,18 @@ (pass-if "char=? #\\A #\\A" (char=? #\A #\A)) - (expect-fail "char=? #\\A #\\a" - (char=? #\A #\a)) + (pass-if "char=? #\\A #\\a" + (not (char=? #\A #\a))) - (expect-fail "char=? #\\A #\\B" - (char=? #\A #\B)) + (pass-if "char=? #\\A #\\B" + (not (char=? #\A #\B))) - (expect-fail "char=? #\\B #\\A" - (char=? #\A #\B)) + (pass-if "char=? #\\B #\\A" + (not (char=? #\A #\B))) ;; char<? - (expect-fail "char<? #\\A #\\A" - (char<? #\A #\A)) + (pass-if "char<? #\\A #\\A" + (not (char<? #\A #\A))) (pass-if "char<? #\\A #\\a" (char<? #\A #\a)) @@ -64,8 +64,8 @@ (pass-if "char<? #\\A #\\B" (char<? #\A #\B)) - (expect-fail "char<? #\\B #\\A" - (char<? #\B #\A)) + (pass-if "char<? #\\B #\\A" + (not (char<? #\B #\A))) ;; char<=? (pass-if "char<=? #\\A #\\A" @@ -77,18 +77,18 @@ (pass-if "char<=? #\\A #\\B" (char<=? #\A #\B)) - (expect-fail "char<=? #\\B #\\A" - (char<=? #\B #\A)) + (pass-if "char<=? #\\B #\\A" + (not (char<=? #\B #\A))) ;; char>? - (expect-fail "char>? #\\A #\\A" - (char>? #\A #\A)) + (pass-if "char>? #\\A #\\A" + (not (char>? #\A #\A))) - (expect-fail "char>? #\\A #\\a" - (char>? #\A #\a)) + (pass-if "char>? #\\A #\\a" + (not (char>? #\A #\a))) - (expect-fail "char>? #\\A #\\B" - (char>? #\A #\B)) + (pass-if "char>? #\\A #\\B" + (not (char>? #\A #\B))) (pass-if "char>? #\\B #\\A" (char>? #\B #\A)) @@ -97,11 +97,11 @@ (pass-if "char>=? #\\A #\\A" (char>=? #\A #\A)) - (expect-fail "char>=? #\\A #\\a" - (char>=? #\A #\a)) + (pass-if "char>=? #\\A #\\a" + (not (char>=? #\A #\a))) - (expect-fail "char>=? #\\A #\\B" - (char>=? #\A #\B)) + (pass-if "char>=? #\\A #\\B" + (not (char>=? #\A #\B))) (pass-if "char>=? #\\B #\\A" (char>=? #\B #\A)) @@ -113,24 +113,24 @@ (pass-if "char-ci=? #\\A #\\a" (char-ci=? #\A #\a)) - (expect-fail "char-ci=? #\\A #\\B" - (char-ci=? #\A #\B)) + (pass-if "char-ci=? #\\A #\\B" + (not (char-ci=? #\A #\B))) - (expect-fail "char-ci=? #\\B #\\A" - (char-ci=? #\A #\B)) + (pass-if "char-ci=? #\\B #\\A" + (not (char-ci=? #\A #\B))) ;; char-ci<? - (expect-fail "char-ci<? #\\A #\\A" - (char-ci<? #\A #\A)) + (pass-if "char-ci<? #\\A #\\A" + (not (char-ci<? #\A #\A))) - (expect-fail "char-ci<? #\\A #\\a" - (char-ci<? #\A #\a)) + (pass-if "char-ci<? #\\A #\\a" + (not (char-ci<? #\A #\a))) (pass-if "char-ci<? #\\A #\\B" (char-ci<? #\A #\B)) - (expect-fail "char-ci<? #\\B #\\A" - (char-ci<? #\B #\A)) + (pass-if "char-ci<? #\\B #\\A" + (not (char-ci<? #\B #\A))) ;; char-ci<=? (pass-if "char-ci<=? #\\A #\\A" @@ -142,18 +142,18 @@ (pass-if "char-ci<=? #\\A #\\B" (char-ci<=? #\A #\B)) - (expect-fail "char-ci<=? #\\B #\\A" - (char-ci<=? #\B #\A)) + (pass-if "char-ci<=? #\\B #\\A" + (not (char-ci<=? #\B #\A))) ;; char-ci>? - (expect-fail "char-ci>? #\\A #\\A" - (char-ci>? #\A #\A)) + (pass-if "char-ci>? #\\A #\\A" + (not (char-ci>? #\A #\A))) - (expect-fail "char-ci>? #\\A #\\a" - (char-ci>? #\A #\a)) + (pass-if "char-ci>? #\\A #\\a" + (not (char-ci>? #\A #\a))) - (expect-fail "char-ci>? #\\A #\\B" - (char-ci>? #\A #\B)) + (pass-if "char-ci>? #\\A #\\B" + (not (char-ci>? #\A #\B))) (pass-if "char-ci>? #\\B #\\A" (char-ci>? #\B #\A)) @@ -165,8 +165,8 @@ (pass-if "char-ci>=? #\\A #\\a" (char-ci>=? #\A #\a)) - (expect-fail "char-ci>=? #\\A #\\B" - (char-ci>=? #\A #\B)) + (pass-if "char-ci>=? #\\A #\\B" + (not (char-ci>=? #\A #\B))) (pass-if "char-ci>=? #\\B #\\A" (char-ci>=? #\B #\A))) diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test index dc06f0795..ff31c8605 100644 --- a/test-suite/tests/list.test +++ b/test-suite/tests/list.test @@ -439,15 +439,15 @@ (with-test-prefix "wrong argument" - (expect-fail-exception "improper list and empty list" + (pass-if-exception "improper list and empty list" exception:wrong-type-arg (append! (cons 1 2) '())) - (expect-fail-exception "improper list and list" + (pass-if-exception "improper list and list" exception:wrong-type-arg (append! (cons 1 2) (list 3 4))) - (expect-fail-exception "list, improper list and list" + (pass-if-exception "list, improper list and list" exception:wrong-type-arg (append! (list 1 2) (cons 3 4) (list 5 6))) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index a6697c9a3..ddbd2097e 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -4845,7 +4845,7 @@ (test+/- n d)))))) (with-test-prefix "divide by zero" - (for `((0 0.0 +0.0)) ;; denominators + (for `((0 0.0 -0.0)) ;; denominators (lambda (d) (for `((15 ,(* 3/2 big) 18.0 33/7 0 0.0 -0.0 +inf.0 -inf.0 +nan.0)) ;; numerators diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index 60c853cf4..6e02255ad 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -401,6 +401,19 @@ (lambda () (read-disable 'hungry-eol-escapes)))))) +(with-test-prefix "per-port-read-options" + (pass-if "case-sensitive" + (equal? '(guile GuiLe gUIle) + (with-read-options '(case-insensitive) + (lambda () + (with-input-from-string "GUIle #!no-fold-case GuiLe gUIle" + (lambda () + (list (read) (read) (read)))))))) + (pass-if "case-insensitive" + (equal? '(GUIle guile guile) + (with-input-from-string "GUIle #!fold-case GuiLe gUIle" + (lambda () + (list (read) (read) (read))))))) (with-test-prefix "#;" (for-each diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test index c2b65a64c..eba415314 100644 --- a/test-suite/tests/regexp.test +++ b/test-suite/tests/regexp.test @@ -1,8 +1,9 @@ ;;;; regexp.test --- test Guile's regexps -*- coding: utf-8; mode: scheme -*- ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 ;;;; -;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. -;;;; +;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008, 2009, 2010, +;;;; 2012 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 @@ -131,7 +132,14 @@ (lambda (match result) (cons (match:substring match) result)) - (logior regexp/notbol regexp/noteol))))) + (logior regexp/notbol regexp/noteol)))) + + (pass-if "regexp/notbol is set correctly" + (equal? '("foo") + (fold-matches "^foo" "foofoofoofoo" '() + (lambda (match result) + (cons (match:substring match) + result)))))) ;;; @@ -282,4 +290,12 @@ (with-locale "en_US.utf8" ;; bug #31650 (equal? (match:substring (string-match ".*" "calçot") 0) - "calçot")))) + "calçot"))) + + (pass-if "match structures refer to char offsets, non-ASCII pattern" + (with-locale "en_US.utf8" + ;; bug #31650 + (equal? (match:substring (string-match "λ: The Ultimate (.*)" + "λ: The Ultimate GOTO") + 1) + "GOTO")))) diff --git a/test-suite/tests/srfi-105.test b/test-suite/tests/srfi-105.test new file mode 100644 index 000000000..99a084bb3 --- /dev/null +++ b/test-suite/tests/srfi-105.test @@ -0,0 +1,240 @@ +;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*- +;;;; +;;;; Copyright (C) 2012 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-fluids ((%default-port-encoding #f)) + (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) + (equal? (source-property sexp 'column) 3)))) + (pass-if "neoteric expression" + (let ((sexp (with-read-options '(curly-infix positions) + (lambda () + (read-string " { f(x) }"))))) + (and (equal? (source-property sexp 'line) 0) + (equal? (source-property sexp 'column) 3))))) + + ;; 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)))) diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test index 8537d49b6..62645d918 100644 --- a/test-suite/tests/srfi-31.test +++ b/test-suite/tests/srfi-31.test @@ -1,6 +1,6 @@ ;;;; srfi-31.test --- Test suite for Guile's SRFI-31 functions. -*- scheme -*- ;;;; -;;;; Copyright (C) 2004, 2006, 2010 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2006, 2010, 2012 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 @@ -22,9 +22,10 @@ (with-test-prefix "rec special form" - (pass-if-exception "bogus variable" '(misc-error . ".*") + (pass-if-exception "bogus variable" + exception:syntax-pattern-unmatched (eval '(rec #:foo) (current-module))) - + (pass-if "rec expressions" (let ((ones-list (rec ones (cons 1 (delay ones))))) (and (= 1 (car ones-list)) diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index d892b7077..679e17326 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -557,7 +557,67 @@ (pass-if "char 255" (equal? '("a" "b") (string-split (string #\a (integer->char 255) #\b) - (integer->char 255))))) + (integer->char 255)))) + + (pass-if "empty string - char" + (equal? '("") + (string-split "" #\:))) + + (pass-if "non-empty - char - no delimiters" + (equal? '("foobarfrob") + (string-split "foobarfrob" #\:))) + + (pass-if "non-empty - char - delimiters" + (equal? '("foo" "bar" "frob") + (string-split "foo:bar:frob" #\:))) + + (pass-if "non-empty - char - leading delimiters" + (equal? '("" "" "foo" "bar" "frob") + (string-split "::foo:bar:frob" #\:))) + + (pass-if "non-empty - char - trailing delimiters" + (equal? '("foo" "bar" "frob" "" "") + (string-split "foo:bar:frob::" #\:))) + + (pass-if "empty string - charset" + (equal? '("") + (string-split "" (char-set #\:)))) + + (pass-if "non-empty - charset - no delimiters" + (equal? '("foobarfrob") + (string-split "foobarfrob" (char-set #\:)))) + + (pass-if "non-empty - charset - delimiters" + (equal? '("foo" "bar" "frob") + (string-split "foo:bar:frob" (char-set #\:)))) + + (pass-if "non-empty - charset - leading delimiters" + (equal? '("" "" "foo" "bar" "frob") + (string-split "::foo:bar:frob" (char-set #\:)))) + + (pass-if "non-empty - charset - trailing delimiters" + (equal? '("foo" "bar" "frob" "" "") + (string-split "foo:bar:frob::" (char-set #\:)))) + + (pass-if "empty string - pred" + (equal? '("") + (string-split "" (negate char-alphabetic?)))) + + (pass-if "non-empty - pred - no delimiters" + (equal? '("foobarfrob") + (string-split "foobarfrob" (negate char-alphabetic?)))) + + (pass-if "non-empty - pred - delimiters" + (equal? '("foo" "bar" "frob") + (string-split "foo:bar:frob" (negate char-alphabetic?)))) + + (pass-if "non-empty - pred - leading delimiters" + (equal? '("" "" "foo" "bar" "frob") + (string-split "::foo:bar:frob" (negate char-alphabetic?)))) + + (pass-if "non-empty - pred - trailing delimiters" + (equal? '("foo" "bar" "frob" "" "") + (string-split "foo:bar:frob::" (negate char-alphabetic?))))) (with-test-prefix "substring-move!" diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test index 431a014b8..0e3b2417e 100644 --- a/test-suite/tests/structs.test +++ b/test-suite/tests/structs.test @@ -126,7 +126,49 @@ (not (or (equal? (make-ball red "Bob") (make-ball green "Bob")) (equal? (make-ball red "Bob") (make-ball red "Bill")))))) + +(with-test-prefix "hash" + + (pass-if "simple structs" + (let* ((v (make-vtable "pr")) + (s1 (make-struct v 0 "hello")) + (s2 (make-struct v 0 "hello"))) + (= (hash s1 7777) (hash s2 7777)))) + + (pass-if "different structs" + (let* ((v (make-vtable "pr")) + (s1 (make-struct v 0 "hello")) + (s2 (make-struct v 0 "world"))) + (or (not (= (hash s1 7777) (hash s2 7777))) + (throw 'unresolved)))) + + (pass-if "different struct types" + (let* ((v1 (make-vtable "pr")) + (v2 (make-vtable "pr")) + (s1 (make-struct v1 0 "hello")) + (s2 (make-struct v2 0 "hello"))) + (or (not (= (hash s1 7777) (hash s2 7777))) + (throw 'unresolved)))) + (pass-if "more complex structs" + (let ((s1 (make-ball red (string-copy "Bob"))) + (s2 (make-ball red (string-copy "Bob")))) + (= (hash s1 7777) (hash s2 7777)))) + + (pass-if "struct with weird fields" + (let* ((v (make-vtable "prurph")) + (s1 (make-struct v 0 "hello" 123 "invisible-secret1")) + (s2 (make-struct v 0 "hello" 123 "invisible-secret2"))) + (= (hash s1 7777) (hash s2 7777)))) + + (pass-if "cyclic structs" + (let* ((v (make-vtable "pw")) + (a (make-struct v 0 #f)) + (b (make-struct v 0 a))) + (struct-set! a 0 b) + (and (hash a 7777) (hash b 7777) #t)))) + + ;; ;; make-struct ;; diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test index 98c44b91b..8a4b593fd 100644 --- a/test-suite/tests/texinfo.test +++ b/test-suite/tests/texinfo.test @@ -208,9 +208,8 @@ (test-body "@code{arg}" '((para (code "arg")))) - ;; FIXME: Why no enclosing para here? Probably a bug. (test-body "@url{arg}" - '((uref (% (url "arg"))))) + '((para (uref (% (url "arg")))))) (test-body "@code{ }" '((para (code)))) (test-body "@code{ @code{} }" diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 5d12f0c48..4767d624a 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -58,6 +58,20 @@ (assert-tree-il->glil with-partial-evaluation in pat test ...)))) +(define-syntax-rule (pass-if-primitives-resolved in expected) + (pass-if (format #f "primitives-resolved in ~s" 'in) + (let* ((module (let ((m (make-module))) + (beautify-user-module! m) + m)) + (orig (parse-tree-il 'in)) + (resolved (expand-primitives! (resolve-primitives! orig module)))) + (or (equal? (unparse-tree-il resolved) 'expected) + (begin + (format (current-error-port) + "primitive test failed: got ~s, expected ~s" + resolved 'expected) + #f))))) + (define-syntax pass-if-tree-il->scheme (syntax-rules () ((_ in pat) @@ -70,6 +84,69 @@ (_ #f)))))) +(with-test-prefix "primitives" + + (with-test-prefix "eqv?" + + (pass-if-primitives-resolved + (primcall eqv? (toplevel x) (const #f)) + (primcall eq? (const #f) (toplevel x))) + + (pass-if-primitives-resolved + (primcall eqv? (toplevel x) (const ())) + (primcall eq? (const ()) (toplevel x))) + + (pass-if-primitives-resolved + (primcall eqv? (const #t) (lexical x y)) + (primcall eq? (const #t) (lexical x y))) + + (pass-if-primitives-resolved + (primcall eqv? (const this-is-a-symbol) (toplevel x)) + (primcall eq? (const this-is-a-symbol) (toplevel x))) + + (pass-if-primitives-resolved + (primcall eqv? (const 42) (toplevel x)) + (primcall eq? (const 42) (toplevel x))) + + (pass-if-primitives-resolved + (primcall eqv? (const 42.0) (toplevel x)) + (primcall eqv? (const 42.0) (toplevel x))) + + (pass-if-primitives-resolved + (primcall eqv? (const #nil) (toplevel x)) + (primcall eq? (const #nil) (toplevel x)))) + + (with-test-prefix "equal?" + + (pass-if-primitives-resolved + (primcall equal? (toplevel x) (const #f)) + (primcall eq? (const #f) (toplevel x))) + + (pass-if-primitives-resolved + (primcall equal? (toplevel x) (const ())) + (primcall eq? (const ()) (toplevel x))) + + (pass-if-primitives-resolved + (primcall equal? (const #t) (lexical x y)) + (primcall eq? (const #t) (lexical x y))) + + (pass-if-primitives-resolved + (primcall equal? (const this-is-a-symbol) (toplevel x)) + (primcall eq? (const this-is-a-symbol) (toplevel x))) + + (pass-if-primitives-resolved + (primcall equal? (const 42) (toplevel x)) + (primcall eq? (const 42) (toplevel x))) + + (pass-if-primitives-resolved + (primcall equal? (const 42.0) (toplevel x)) + (primcall equal? (const 42.0) (toplevel x))) + + (pass-if-primitives-resolved + (primcall equal? (const #nil) (toplevel x)) + (primcall eq? (const #nil) (toplevel x))))) + + (with-test-prefix "tree-il->scheme" (pass-if-tree-il->scheme (case-lambda ((a) a) ((b c) (list b c))) @@ -1704,3 +1781,8 @@ #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "unsupported format option")))))))) + +;; Local Variables: +;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1) +;; eval: (put 'pass-if-tree-il->scheme 'scheme-indent-function 1) +;; End: diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test index 4621a19f9..3f6e7e3ab 100644 --- a/test-suite/tests/web-uri.test +++ b/test-suite/tests/web-uri.test @@ -258,4 +258,6 @@ (equal? "foo bar" (uri-decode "foo+bar")))) (with-test-prefix "encode" - (pass-if (equal? "foo%20bar" (uri-encode "foo bar")))) + (pass-if (equal? "foo%20bar" (uri-encode "foo bar"))) + (pass-if (equal? "foo%0a%00bar" (uri-encode "foo\n\x00bar"))) + (pass-if (equal? "%3c%3e%5c%5e" (uri-encode "<>\\^")))) |