mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-06 15:40:29 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
Moved scm_i_struct_hash from struct.c to hash.c and made it static. The port's alist is now a field of 'scm_t_port'. Conflicts: libguile/arrays.c libguile/hash.c libguile/ports.c libguile/print.h libguile/read.c
This commit is contained in:
Mark H Weaver
commit
fa980bcc0f
53 changed files with 1677 additions and 531 deletions
|
|
@ -136,6 +136,7 @@ SCM_TESTS = tests/00-initial-env.test \
|
|||
tests/srfi-67.test \
|
||||
tests/srfi-69.test \
|
||||
tests/srfi-88.test \
|
||||
tests/srfi-105.test \
|
||||
tests/srfi-4.test \
|
||||
tests/srfi-9.test \
|
||||
tests/statprof.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)))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"))))
|
||||
|
|
|
|||
240
test-suite/tests/srfi-105.test
Normal file
240
test-suite/tests/srfi-105.test
Normal file
|
|
@ -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))))
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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!"
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -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{} }"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -69,6 +83,69 @@
|
|||
(pat (guard guard-exp) #t)
|
||||
(_ #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
|
||||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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 "<>\\^"))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue