diff options
author | Christine Lemmer-Webber <cwebber@dustycloud.org> | 2021-10-10 20:59:04 -0400 |
---|---|---|
committer | Christine Lemmer-Webber <cwebber@dustycloud.org> | 2021-10-10 20:59:04 -0400 |
commit | 204cb986469b2751a3c3347a34a8013c1a0b6954 (patch) | |
tree | e91534db67add400e5213ec3becb6ab48544b470 /test-suite | |
parent | b03b359b5b16c040c485a565f3ce92481ea43f41 (diff) | |
parent | e60469c8b6936575c079faaffa40a340e1d49f3c (diff) | |
download | guile-204cb986469b2751a3c3347a34a8013c1a0b6954.tar.gz |
Merge branch 'main' into compile-to-js-merge
Diffstat (limited to 'test-suite')
-rw-r--r-- | test-suite/tests/arrays.test | 2 | ||||
-rw-r--r-- | test-suite/tests/bytevectors.test | 14 | ||||
-rw-r--r-- | test-suite/tests/compiler.test | 130 | ||||
-rw-r--r-- | test-suite/tests/match.test | 13 | ||||
-rw-r--r-- | test-suite/tests/match.test.upstream | 16 | ||||
-rw-r--r-- | test-suite/tests/numbers.test | 13 | ||||
-rw-r--r-- | test-suite/tests/reader.test | 5 | ||||
-rw-r--r-- | test-suite/tests/syntax.test | 10 | ||||
-rw-r--r-- | test-suite/tests/vectors.test | 11 |
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" |