changeset 355: |
09f056e9a789 |
parent: |
00d1c8afcdbb
|
child: |
49c3f3d11432 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Tue, 14 May 2024 18:33:03 -0400 |
permissions: |
-rw-r--r-- |
description: |
bugfixes, x test |
1 ;;; tests.lisp --- std system tests 5 ;; TODO: fix false positives when using (eval-test) 10 (:use :cl :std :rt :sb-thread :std/fu)) 11 (in-package :std/tests) 15 ;; prevent threadlocks 16 ;; (setf sb-unix::*on-dangerous-wait* :error) 18 ;; TODO 2024-05-14: fix compilation order of std/fu vs std/readtables 19 (deftest readtables (:disabled nil) 21 (is (typep #`(,a1 ,a1 ',a1 ,@a1) 'function)) 22 (is (string= #"test "foo" "# "test \"foo\" ")) 23 ;; from curry-compose-reader-macros test suite 24 (is (equal (funcall {list 1} 2) '(1 2))) ;; curry.1 25 (is (equal (mapcar {+ 1} '(1 2 3 4)) '(2 3 4 5))) ;; curry.2 26 (is (equal (funcall {1 list 1} 2) '(1 2))) ;; curry.fixed-arity 27 (is (equal (funcall {2 list _ 2} 3 4) '(3 4 2))) ;; curry.fixed-arity.2 29 (locally (declare (optimize safety)) 31 (progn (funcall f) nil)))) ;; curry.fixed-arity.1 33 (locally (declare (optimize safety)) 35 (progn (funcall f 'a 'b) nil)))) ;; curry.fixed-arity-error.2 36 (is (equal (funcall {list _ 1} 2) '(2 1))) ;; rcurry.1 37 (is (equal (mapcar {- _ 1} '(1 2 3 4)) '(0 1 2 3))) ;; rcurry.2 38 (is (equal (funcall [{* 3} #'1+] 1) 6)) ;; compose.1 39 (is (equal (funcall ['1+ '1+] 1) 3)) ;; compose.2 40 (is (equal (funcall [#'1+] 1) 2)) ;; compose.3 41 (is (equal (funcall [#'values] 1 2 3) (values 1 2 3))) ;; compose.4 42 (is (equal (funcall «list {* 2} {* 3}» 4) '(8 12))) ;; join.1 43 (is (equal (mapcar «and {< 2} 'evenp (constantly t)» '(1 2 3 4)) (list nil nil nil t))) ;; join.2 45 (is (equal (mapcar ‹typecase (number #'1+) (string :str)› '(1 "this" 2 "that")) '(2 :str 3 :str))) 47 (is (equal (mapcar ‹cond (#'evenp {+ 100}) (#'oddp {+ 200})› '(1 2 3 4)) '(201 102 203 104))) 49 (is (equal (mapcar ‹if #'evenp {list :a} {list :b}› '(1 2 3 4)) 50 '((:b 1) (:a 2) (:b 3) (:a 4)))) 52 (is (equal (mapcar ‹when 'evenp {+ 4}› '(1 2 3 4)) (list nil 6 nil 8))) 54 (is (equal (mapcar ‹unless 'evenp {+ 4}› '(1 2 3 4)) (list 5 nil 7 nil)))) 57 "Test standard symbol utils" 59 (is (not (equalp (make-gensym 'a) (make-gensym 'a)))) 60 (is (eq 'std/tests::foo (format-symbol :std/tests "~A" 'foo))) 61 (is (eq (make-keyword 'fizz) :fizz))) 65 "Test standard string utils" 66 (is (typep "test" 'string-designator)) 67 (is (typep 'test 'string-designator)) 68 (is (typep #\C 'string-designator)) 69 (is (not (typep 0 'string-designator)))) 72 "Test standard list utils" 73 ;; same object - a literal 74 (is (eq (ensure-car '(0)) (ensure-car 0))) 75 (is (eq (ensure-car '(nil)) (ensure-car nil))) 77 (is (not (eq (ensure-cons 0) (ensure-cons 0)))) 78 (is (equal (ensure-cons 0) (ensure-cons 0)))) 81 "Test standard error handlers" 82 (is (eql 'testing-err (deferror testing-err (std-error) nil (:auto t) (:documentation "testing"))))) 85 "Test standard thread functionality." 86 (is (eq *current-thread* 87 (find (thread-name *current-thread*) (list-all-threads) 88 :key #'thread-name :test #'equal))) 89 (is (find-thread-by-id (car (thread-id-list)))) 90 (is (not (zerop (thread-count)))) 92 (make-threads 4 (lambda () (is (= 42 (1+ 41)))) :name "threads"))) 93 (loop for th in threads 94 do (sb-thread:join-thread th)) 95 (loop for th in threads 96 collect (is (not (sb-thread:thread-alive-p th))))) 97 (let ((m (make-mutex :name "mutex-test"))) 102 (make-thread (lambda () 103 (with-mutex (m :timeout 0.1) 106 (make-thread (lambda () 107 (with-mutex (m :timeout 0.1) 109 (let* ((sym (gensym)) 110 (s (make-semaphore :name "semaphore-test")) 111 (th (make-thread (lambda () (wait-on-semaphore s))))) 112 (is (equal (multiple-value-list (join-thread th :timeout .001 :default sym)) 113 (list sym :timeout))) 115 (is (join-thread th))) 116 (signals join-thread-error (join-thread *current-thread*)) 118 (let ((m (make-mutex :name "rlock-test"))) 119 (is (not (with-mutex (m) (join-thread (make-thread (lambda () (with-recursive-lock (m :wait-p nil) t))))))) 120 (join-thread (make-thread (lambda () (with-recursive-lock (m :wait-p nil) t)))))) 121 (let ((queue (make-waitqueue :name "queue-test")) 122 (lock (make-mutex :name "lock-test")) 125 (labels ((in-new-thread () 127 (assert (eql (mutex-owner lock) *current-thread*)) 128 (log:info! (condition-wait queue lock)) 129 (assert (eql (mutex-owner lock) *current-thread*)) 132 (setf th (make-thread #'in-new-thread)) 134 (is (null (mutex-owner lock))) 137 (condition-notify queue)) 138 (is (= 0 (join-thread th)))))) 141 "Test various timer functionality." 142 (sb-int:with-progressive-timeout (ttl :seconds 2) 144 (is (/= (ttl) 2.0)))) 147 "Test task-pools, oracles, and workers." 148 (let ((pool1 (make-task-pool))))) 151 "Test standard formatters" 152 (is (string= (format nil "| 1 | 2 | 3 |~%") (fmt-row '(1 2 3)))) 154 ;; note the read-time-eval.. 155 #.(fmt-tree nil '(foobar (:a) (:b) (c) (d)) :layout :down) 164 #.(std:fmt-tree nil '(sk-project :name "foobar" :path "/a/b/c.asd" :vc :hg) :layout :down :plist t) 175 "Test standard anaphoric macros" 179 (is (= 42 (awhen 42 it))) 180 (is (= 3 (acond ((1+ 1) (1+ it))))) 181 (loop for x in '(1 2 3) 182 for y in (funcall (alet ((a 1) (b 2) (c 3)) 183 (lambda () (mapc #'1+ (list a b c))))) 184 collect (is (= x y)))) 186 (deftest pan (:disabled t) 187 "Test standard pandoric macros" 193 (progn (incf b a) (incf c a)))))) 194 (with-pandoric (b c) p 195 (is (= 0 (funcall p nil))) 196 (is (= 1 (funcall p 1))) 200 "Test standard alien utils" 201 (is (= 0 (foreign-int-to-integer 0 4))) 202 (is (= 1 (bool-to-foreign-int t)))) 205 "Test curry functions from Alexandria, found in std/fu. 206 These tests are copied directly from the Alexandria test suite." 208 (let ((curried (curry '+ 3))) 209 (is (= (funcall curried 1 5) 9))) 211 (let ((curried (locally (declare (notinline curry)) 213 (is (= (funcall curried 7) 42))) 215 (let ((curried-form (funcall (compiler-macro-function 'curry) 218 (let ((fun (funcall (compile nil `(lambda () ,curried-form))))) 219 (is (= (funcall fun 2) 4)))) ;; maybe fails? 222 (curried (curry (progn 224 (lambda (y z) (* x y z))) 226 (is (equal (list (funcall curried 7) 231 (let ((r (rcurry '/ 2))) 232 (is (= (funcall r 8) 4))) 235 (curried (rcurry (progn 237 (lambda (y z) (* x y z))) 240 (list (funcall curried 7) ;; 42 241 (funcall curried 7) ;; 42 245 (deftest bits (:disabled t) 246 (define-bitfield testbits 249 (c (unsigned-byte 3) :initform 1) 250 (d (integer -100 100)) 251 (e (member foo bar baz))) 252 (let ((bits (make-testbits))) 253 (is (not (testbits-a bits))) 254 (is (= 0 (testbits-b bits))) 255 (is (= 1 (testbits-c bits))) 256 (is (= -100 (testbits-d bits))) 257 (is (eql 'foo (testbits-e bits)))))