changeset 365: |
49c3f3d11432 |
parent: |
09f056e9a789
|
child: |
9eb2c112aa16 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 24 May 2024 14:40:38 -0400 |
permissions: |
-rw-r--r-- |
description: |
bug fixes and more tweaks for test macros |
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 30 (progn (funcall f) nil))) ;; curry.fixed-arity.1 32 (locally (declare (optimize safety)) 34 (progn (funcall f 'a 'b) nil)))) ;; curry.fixed-arity-error.2 35 (is (equal (funcall {list _ 1} 2) '(2 1))) ;; rcurry.1 36 (is (equal (mapcar {- _ 1} '(1 2 3 4)) '(0 1 2 3))) ;; rcurry.2 37 (is (equal (funcall [{* 3} #'1+] 1) 6)) ;; compose.1 38 (is (equal (funcall ['1+ '1+] 1) 3)) ;; compose.2 39 (is (equal (funcall [#'1+] 1) 2)) ;; compose.3 40 (is (equal (funcall [#'values] 1 2 3) (values 1 2 3))) ;; compose.4 41 (is (equal (funcall «list {* 2} {* 3}» 4) '(8 12))) ;; join.1 42 (is (equal (mapcar «and {< 2} 'evenp (constantly t)» '(1 2 3 4)) (list nil nil nil t))) ;; join.2 44 (is (equal (mapcar ‹typecase (number #'1+) (string :str)› '(1 "this" 2 "that")) '(2 :str 3 :str))) 46 (is (equal (mapcar ‹cond (#'evenp {+ 100}) (#'oddp {+ 200})› '(1 2 3 4)) '(201 102 203 104))) 48 (is (equal (mapcar ‹if #'evenp {list :a} {list :b}› '(1 2 3 4)) 49 '((:b 1) (:a 2) (:b 3) (:a 4)))) 51 (is (equal (mapcar ‹when 'evenp {+ 4}› '(1 2 3 4)) (list nil 6 nil 8))) 53 (is (equal (mapcar ‹unless 'evenp {+ 4}› '(1 2 3 4)) (list 5 nil 7 nil)))) 56 "Test standard symbol utils" 58 (is (not (equalp (make-gensym 'a) (make-gensym 'a)))) 59 (is (eq 'std/tests::foo (format-symbol :std/tests "~A" 'foo))) 60 (is (eq (make-keyword 'fizz) :fizz))) 64 "Test standard string utils" 65 (is (typep "test" 'string-designator)) 66 (is (typep 'test 'string-designator)) 67 (is (typep #\C 'string-designator)) 68 (is (not (typep 0 'string-designator)))) 71 "Test standard list utils" 72 ;; same object - a literal 73 (is (eq (ensure-car '(0)) (ensure-car 0))) 74 (is (eq (ensure-car '(nil)) (ensure-car nil))) 76 (is (not (eq (ensure-cons 0) (ensure-cons 0)))) 77 (is (equal (ensure-cons 0) (ensure-cons 0)))) 80 "Test standard error handlers" 81 (is (eql 'testing-err (deferror testing-err (std-error) nil (:auto t) (:documentation "testing"))))) 84 "Test standard thread functionality." 85 (is (eq *current-thread* 86 (find (thread-name *current-thread*) (list-all-threads) 87 :key #'thread-name :test #'equal))) 88 (is (find-thread-by-id (car (thread-id-list)))) 89 (is (not (zerop (thread-count)))) 91 (make-threads 4 (lambda () (is (= 42 (1+ 41)))) :name "threads"))) 92 (loop for th in threads 93 do (sb-thread:join-thread th)) 94 (loop for th in threads 95 collect (is (not (sb-thread:thread-alive-p th))))) 96 (let ((m (make-mutex :name "mutex-test"))) 101 (make-thread (lambda () 102 (with-mutex (m :timeout 0.1) 105 (make-thread (lambda () 106 (with-mutex (m :timeout 0.1) 108 (let* ((sym (gensym)) 109 (s (make-semaphore :name "semaphore-test")) 110 (th (make-thread (lambda () (wait-on-semaphore s))))) 111 (is (equal (multiple-value-list (join-thread th :timeout .001 :default sym)) 112 (list sym :timeout))) 114 (is (join-thread th))) 115 (signals join-thread-error (join-thread *current-thread*)) 117 (let ((m (make-mutex :name "rlock-test"))) 118 (is (not (with-mutex (m) (join-thread (make-thread (lambda () (with-recursive-lock (m :wait-p nil) t))))))) 119 (join-thread (make-thread (lambda () (with-recursive-lock (m :wait-p nil) t)))))) 120 (let ((queue (make-waitqueue :name "queue-test")) 121 (lock (make-mutex :name "lock-test")) 124 (labels ((in-new-thread () 126 (assert (eql (mutex-owner lock) *current-thread*)) 127 (log:info! (condition-wait queue lock)) 128 (assert (eql (mutex-owner lock) *current-thread*)) 131 (setf th (make-thread #'in-new-thread)) 133 (is (null (mutex-owner lock))) 136 (condition-notify queue)) 137 (is (= 0 (join-thread th)))))) 140 "Test various timer functionality." 141 (sb-int:with-progressive-timeout (ttl :seconds 2) 143 (is (/= (ttl) 2.0)))) 146 "Test task-pools, oracles, and workers." 147 ;; (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)))))