summaryrefslogtreecommitdiff
path: root/test-suite
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite')
-rw-r--r--test-suite/tests/arrays.test2
-rw-r--r--test-suite/tests/bytevectors.test14
-rw-r--r--test-suite/tests/compiler.test130
-rw-r--r--test-suite/tests/match.test13
-rw-r--r--test-suite/tests/match.test.upstream16
-rw-r--r--test-suite/tests/numbers.test13
-rw-r--r--test-suite/tests/reader.test5
-rw-r--r--test-suite/tests/syntax.test10
-rw-r--r--test-suite/tests/vectors.test11
9 files changed, 146 insertions, 68 deletions
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index c2716ed17..3bf433582 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -419,7 +419,7 @@
(eq? a (array-contents (make-shared-array a (const '(0)))))
(eq? a (array-contents (make-shared-array a (const '(0))) #t)))))
- (pass-if "simple vector"
+ (pass-if "plain vector"
(let* ((a (make-array 0 4)))
(eq? a (array-contents a))))
diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test
index 9ae040f1e..732aadb3e 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -65,6 +65,20 @@
(bytevector-fill! bv -128)
bv))
+ ;; This is a Guile-specific extension.
+ (pass-if-equal "bytevector-fill! range arguments I"
+ #vu8(0 0 1 1 1)
+ (let ((bv (make-bytevector 5 0)))
+ (bytevector-fill! bv 1 2)
+ bv))
+
+ ;; This is a Guile-specific extension.
+ (pass-if-equal "bytevector-fill! range arguments II"
+ #vu8(0 0 1 1 0)
+ (let ((bv (make-bytevector 5 0)))
+ (bytevector-fill! bv 1 2 4)
+ bv))
+
(pass-if "bytevector-copy! overlapping"
;; See <http://debbugs.gnu.org/10070>.
(let ((b (u8-list->bytevector '(1 2 3 4 5 6 7 8))))
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 254aaa720..466f2b821 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -302,73 +302,77 @@
'(3 #t #f #nil ()))))
(with-test-prefix "cse auxiliary definitions"
- (define test-code
- '(begin
- (define count 1)
- (set! count count) ;; Avoid inlining
-
- (define (main)
- (define (trampoline thunk)
- (let loop ((i 0) (result #f))
- (cond
- ((< i 1)
- (loop (+ i 1) (thunk)))
- (else
- (unless (= result 42) (error "bad result" result))
- result))))
- (define (test n)
- (let ((matrix (make-vector n)))
- (let loop ((i (- n 1)))
- (when (>= i 0)
- (vector-set! matrix i (make-vector n 42))
- (loop (- i 1))))
- (vector-ref (vector-ref matrix 0) 0)))
-
- (trampoline (lambda () (test count))))
- main))
-
- (define test-proc #f)
- (pass-if "compiling test works"
- (begin
- (set! test-proc (compile test-code))
- (procedure? test-proc)))
-
- (pass-if-equal "test terminates without error" 42
- (test-proc)))
+ (define test-proc
+ (compile
+ '(begin
+ (define count 1)
+ (set! count count) ;; Avoid inlining
+
+ (define (main)
+ (define (trampoline thunk)
+ (let loop ((i 0) (result #f))
+ (cond
+ ((< i 1)
+ (loop (+ i 1) (thunk)))
+ (else
+ (unless (= result 42) (error "bad result" result))
+ result))))
+ (define (test n)
+ (let ((matrix (make-vector n)))
+ (let loop ((i (- n 1)))
+ (when (>= i 0)
+ (vector-set! matrix i (make-vector n 42))
+ (loop (- i 1))))
+ (vector-ref (vector-ref matrix 0) 0)))
+
+ (trampoline (lambda () (test count))))
+ main)))
+
+ (pass-if-equal "running test" 42 (test-proc)))
(with-test-prefix "closure conversion"
- (define test-code
- '(lambda (arg)
- (define (A a)
- (let loop ((ls a))
- (cond ((null? ls)
- (B a))
- ((pair? ls)
- (if (list? (car ls))
- (loop (cdr ls))
- #t))
- (else #t))))
- (define (B b)
- (let loop ((ls b))
- (cond ((null? ls)
- (map A b))
- ((pair? ls)
- (if (list? (car ls))
- (loop (cdr ls))
- (error "bad" b)))
- (else
- (error "bad" b)))))
- (B arg)))
-
- (define test-proc #f)
- (pass-if "compiling test works"
- (begin
- (set! test-proc (compile test-code))
- (procedure? test-proc)))
-
- (pass-if-equal "test terminates without error" '(#t #t)
+ (define test-proc
+ (compile
+ '(lambda (arg)
+ (define (A a)
+ (let loop ((ls a))
+ (cond ((null? ls)
+ (B a))
+ ((pair? ls)
+ (if (list? (car ls))
+ (loop (cdr ls))
+ #t))
+ (else #t))))
+ (define (B b)
+ (let loop ((ls b))
+ (cond ((null? ls)
+ (map A b))
+ ((pair? ls)
+ (if (list? (car ls))
+ (loop (cdr ls))
+ (error "bad" b)))
+ (else
+ (error "bad" b)))))
+ (B arg))))
+
+ (pass-if-equal "running test" '(#t #t)
(test-proc '((V X) (Y Z)))))
+(with-test-prefix "constant propagation"
+ (define test-proc
+ (compile
+ '(lambda (a b)
+ (let ((c (if (and (eq? a 'foo)
+ (eq? b 'bar))
+ 'qux
+ a)))
+ c))))
+
+ (pass-if-equal "one two" 'one (test-proc 'one 'two))
+ (pass-if-equal "one bar" 'one (test-proc 'one 'bar))
+ (pass-if-equal "foo bar" 'qux (test-proc 'foo 'bar))
+ (pass-if-equal "foo two" 'foo (test-proc 'foo 'two)))
+
(with-test-prefix "read-and-compile tree-il"
(let ((code
"\
diff --git a/test-suite/tests/match.test b/test-suite/tests/match.test
index 6bf5bdd2c..b5dface86 100644
--- a/test-suite/tests/match.test
+++ b/test-suite/tests/match.test
@@ -1,6 +1,6 @@
;;;; match.test --- (ice-9 match) -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2021 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
@@ -189,6 +189,17 @@
(($ rtd-3-slots a b c d)
#f))))))
+(with-test-prefix "unify in list patterns"
+ (pass-if-equal "matching" '(1 2 3)
+ (match '((1 2 3) (1 2 3))
+ (((x ...) (x ...)) x)
+ (_ #f)))
+
+ (pass-if-equal "not matching" #f
+ (match '((1 2 3) (1 2 3 4))
+ (((x ...) (x ...)) x)
+ (_ #f))))
+
;;;
;;; Upstream tests, from Chibi-Scheme (3-clause BSD license).
diff --git a/test-suite/tests/match.test.upstream b/test-suite/tests/match.test.upstream
index 7cbb80433..8dd73b566 100644
--- a/test-suite/tests/match.test.upstream
+++ b/test-suite/tests/match.test.upstream
@@ -30,6 +30,22 @@
(test "duplicate symbols bound" 3 (let ((a '(1 2))) (match a ((and (a 2) (1 b)) (+ a b)) (_ #f))))
(test "duplicate quasiquote" 'ok (match '(a b) ((or `(a ,x) `(,x b)) 'ok) (_ #f)))
+(test "duplicate before ellipsis" #f
+ (match '(1 2) ((a a ...) a) (else #f)))
+(test "duplicate ellipsis pass" '(1 2)
+ (match '((1 2) (1 2)) (((x ...) (x ...)) x) (else #f)))
+(test "duplicate ellipsis fail" #f
+ (match '((1 2) (1 2 3)) (((x ...) (x ...)) x) (else #f)))
+(test "duplicate ellipsis trailing" '(1 2)
+ (match '((1 2 3) (1 2 3)) (((x ... 3) (x ... 3)) x) (else #f)))
+(test "duplicate ellipsis trailing fail" #f
+ (match '((1 2 3) (1 1 3)) (((x ... 3) (x ... 3)) x) (else #f)))
+(test "duplicate ellipsis fail trailing" #f
+ (match '((1 2 3) (1 2 4)) (((x ... 3) (x ... 3)) x) (else #f)))
+(test "ellipsis trailing" '(3 1 2)
+ (match '(1 2 3) ((x ... y) (cons y x)) (else #f)))
+
+
(test "ellipses" '((a b c) (1 2 3))
(match '((a . 1) (b . 2) (c . 3))
(((x . y) ___) (list x y))))
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 59e370ec9..8f644874d 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -1,6 +1,6 @@
;;;; numbers.test --- tests guile's numbers -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2003-2006, 2009-2013,
-;;;; 2015, 2018 Free Software Foundation, Inc.
+;;;; 2015, 2018, 2021 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
@@ -19,6 +19,7 @@
(define-module (test-suite test-numbers)
#:use-module (test-suite lib)
#:use-module (ice-9 documentation)
+ #:autoload (system base compile) (compile)
#:use-module (srfi srfi-1) ; list library
#:use-module (srfi srfi-11)) ; let-values
@@ -5468,7 +5469,15 @@
(ash-variant 123 (expt 2 1000)))))
(test-ash-variant 'ash ash floor #f)
- (test-ash-variant 'round-ash round-ash round #t))
+ (test-ash-variant 'round-ash round-ash round #t)
+
+ (pass-if-equal "ash at -O1" ;https://issues.guix.gnu.org/50696
+ '(4 1)
+ (compile '((lambda (x y)
+ (list (ash x 2) (ash y -2))) 1 4)
+ #:to 'value
+ #:opts '(#:cps? #f #:partial-eval? #f)
+ #:optimization-level 1)))
;;;
;;; regressions
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 1481a0a5d..ad7c6d575 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -536,6 +536,11 @@
(with-test-prefix "#{}#"
(pass-if (equal? (read-string "#{}#") '#{}#))
+ ;; See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=49623>
+ (pass-if (equal? (read-string "#{}}#") (string->symbol "}")))
+ (pass-if (equal? (read-string "#{}}}#") (string->symbol "}}")))
+ (pass-if (equal? (read-string "#{{}}#") (string->symbol "{}")))
+ (pass-if (equal? (read-string "#{{}b}#") (string->symbol "{}b")))
(pass-if (not (equal? (read-string "(a #{.}# b)") '(a . b))))
(pass-if (equal? (read-string "#{a}#") 'a))
(pass-if (equal? (read-string "#{a b}#") '#{a b}#))
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index a2999ac43..510e7104d 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -1684,6 +1684,16 @@
(hash interpreted most-positive-fixnum)
(hash compiled most-positive-fixnum))))
+(with-test-prefix "#nil in syntaxes"
+ (pass-if-equal "does not crash"
+ 42
+ (let ()
+ (define-syntax foo
+ (syntax-rules ()
+ ;; In 3.0.7 this would crash with
+ ;; unknown location: unexpected syntax in form ()
+ ((_ x) (when (eq? x #nil) 42))))
+ (foo #nil))))
;;; Local Variables:
;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)
diff --git a/test-suite/tests/vectors.test b/test-suite/tests/vectors.test
index 97b3f187a..371b51840 100644
--- a/test-suite/tests/vectors.test
+++ b/test-suite/tests/vectors.test
@@ -31,9 +31,18 @@
exception:immutable-vector
(vector-set! '#(1 2 3) 0 4)))
+(with-test-prefix "vector-copy"
+
+ (pass-if "defaults"
+ (equal? #(1 2 3) (vector-copy #(1 2 3))))
+ (pass-if "default end"
+ (equal? #(2 3) (vector-copy #(1 2 3) 1)))
+ (pass-if "start end"
+ (equal? #(2) (vector-copy #(1 2 3) 1 2))))
+
(with-test-prefix "vector->list"
- (pass-if "simple vector"
+ (pass-if "plain vector"
(equal? '(1 2 3) (vector->list #(1 2 3))))
(pass-if "string vector 1"