1;;;; sort.test --- tests Guile's sort functions -*- scheme -*- 2;;;; Copyright (C) 2003, 2006, 2007, 2009, 2011, 2017 3;;;; Free Software Foundation, Inc. 4;;;; 5;;;; This library is free software; you can redistribute it and/or 6;;;; modify it under the terms of the GNU Lesser General Public 7;;;; License as published by the Free Software Foundation; either 8;;;; version 3 of the License, or (at your option) any later version. 9;;;; 10;;;; This library is distributed in the hope that it will be useful, 11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13;;;; Lesser General Public License for more details. 14;;;; 15;;;; You should have received a copy of the GNU Lesser General Public 16;;;; License along with this library; if not, write to the Free Software 17;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 19(use-modules (test-suite lib) 20 (ice-9 arrays)) 21 22(set! *random-state* (seed->random-state 2017)) 23 24; Randomly shuffle u in place, using Fisher-Yates algorithm. 25(define (array-shuffle! v) 26 (unless (= 1 (array-rank v)) (throw 'bad-rank (array-rank v))) 27 (let* ((dims (car (array-shape v))) 28 (lo (car dims))) 29 (let loop ((i (cadr dims))) 30 (if (> i lo) 31 (let* ((j (+ lo (random (- (1+ i) lo)))) 32 (t (array-ref v j))) 33 (array-set! v (array-ref v i) j) 34 (array-set! v t i) 35 (loop (- i 1))) 36 v)))) 37 38(define* (test-sort! v #:optional (sort sort)) 39 (array-index-map! v (lambda (i) i)) 40 (let ((before (array-copy v))) 41 (array-shuffle! v) 42 (let ((after (array-copy v))) 43 (and 44 (equal? before (sort v <)) 45 (equal? after v))))) 46 47(define* (test-sort-inplace! v #:optional (sort! sort!)) 48 (array-index-map! v (lambda (i) i)) 49 (let ((before (array-copy v))) 50 (array-shuffle! v) 51 (and (equal? before (sort! v <)) 52 (equal? before v) 53 (sorted? v <)))) 54 55 56(with-test-prefix "sort" 57 58 (pass-if-exception "less function taking less than two arguments" 59 exception:wrong-num-args 60 (sort '(1 2) (lambda (x) #t))) 61 62 (pass-if-exception "less function taking more than two arguments" 63 exception:wrong-num-args 64 (sort '(1 2) (lambda (x y z) z))) 65 66 (pass-if "sort of vector" 67 (test-sort! (make-vector 100))) 68 69 (pass-if "sort of typed vector" 70 (test-sort! (make-f64vector 100)))) 71 72 73(with-test-prefix "sort!" 74 75 (pass-if "sort of empty vector" 76 (test-sort-inplace! (vector))) 77 78 (pass-if "sort of vector" 79 (test-sort-inplace! (make-vector 100))) 80 81 (pass-if "sort of empty typed vector" 82 (test-sort-inplace! (f64vector))) 83 84 (pass-if "sort! of typed vector" 85 (test-sort-inplace! (make-f64vector 100))) 86 87 (pass-if "sort! of non-contigous array" 88 (let* ((a (make-array 0 100 3)) 89 (v (make-shared-array a (lambda (i) (list i 0)) 100))) 90 (test-sort-inplace! v))) 91 92 (pass-if "sort! of non-contigous typed array" 93 (let* ((a (make-typed-array 'f64 0 99 3)) 94 (v (make-shared-array a (lambda (i) (list i 0)) 99))) 95 (test-sort-inplace! v))) 96 97 (pass-if "sort! of negative-increment array" 98 (let* ((a (make-array 0 100 3)) 99 (v (make-shared-array a (lambda (i) (list (- 99 i) 0)) 100))) 100 (test-sort-inplace! v))) 101 102 (pass-if "sort! of non-zero base index array" 103 (test-sort-inplace! (make-array 0 '(-99 0)))) 104 105 (pass-if "sort! of non-zero base index typed array" 106 (test-sort-inplace! (make-typed-array 'f64 0 '(-99 0)))) 107 108 (pass-if "sort! of negative-increment typed array" 109 (let* ((a (make-typed-array 'f64 0 99 3)) 110 (v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99))) 111 (test-sort-inplace! v)))) 112 113 114(with-test-prefix "stable-sort!" 115 116 (pass-if "stable-sort!" 117 (let ((v (make-vector 100))) 118 (test-sort-inplace! v stable-sort!))) 119 120 (pass-if "stable-sort! of non-contigous array" 121 (let* ((a (make-array 0 100 3)) 122 (v (make-shared-array a (lambda (i) (list i 0)) 100))) 123 (test-sort-inplace! v stable-sort!))) 124 125 (pass-if "stable-sort! of negative-increment array" 126 (let* ((a (make-array 0 100 3)) 127 (v (make-shared-array a (lambda (i) (list (- 99 i) 0)) 100))) 128 (test-sort-inplace! v stable-sort!))) 129 130 (pass-if "stable-sort! of non-zero base index array" 131 (test-sort-inplace! (make-array 0 '(-99 0)) stable-sort!))) 132 133 134(with-test-prefix "stable-sort" 135 136 ;; in guile 1.8.0 and 1.8.1 this test failed, an empty list provoked a 137 ;; wrong-type-arg exception (where it shouldn't) 138 (pass-if "empty list" 139 (eq? '() (stable-sort '() <))) 140 141 ;; Ditto here, but up to 2.0.1 and 2.1.0 and invoking undefined 142 ;; behavior (integer underflow) leading to crashes. 143 (pass-if "empty vector" 144 (equal? '#() (stable-sort '#() <)))) 145 146 147(with-test-prefix "mutable/immutable arguments" 148 149 (with-test-prefix/c&e "immutable arguments" 150 151 (pass-if "sort! of empty vector" 152 (equal? #() (sort! (vector) <))) 153 154 (pass-if "sort of immutable vector" 155 (equal? #(0 1) (sort #(1 0) <)))) 156 157 (pass-if-exception "sort! of mutable vector (compile)" 158 exception:wrong-type-arg 159 (compile '(sort! #(0) <) #:to 'value #:env (current-module)))) 160