Coverage report: /home/ellis/comp/core/std/tests/pkg.lisp

KindCoveredAll%
expression018 0.0
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; tests.lisp --- std system tests
2
 
3
 ;;; Commentary:
4
 
5
 ;; TODO: fix false positives when using (eval-test)
6
 
7
 ;;; Code:
8
 (in-package :std-int)
9
 (defpkg :std/tests
10
   (:use :cl :std :rt :sb-thread :sb-alien))
11
 (in-package :std/tests)
12
 (defsuite :std)
13
 (in-suite :std)
14
 (in-readtable :std)
15
 ;; prevent threadlocks
16
 ;; (setf sb-unix::*on-dangerous-wait* :error)
17
 
18
 ;; TODO 2024-05-14: fix compilation order of std/fu vs std/readtables
19
 (deftest readtables ()
20
   "Test :std readtable"
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
28
   (signals error
29
     (let ((f {1 list 1}))
30
       (progn (funcall f) nil))) ;; curry.fixed-arity.1
31
   (signals error
32
     (locally (declare (optimize safety))
33
       (let ((f {1 list 1}))
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
43
   ;; typecase-bracket
44
   ;; (is (equal (mapcar ‹typecase (number #'1+) (string :str)› '(1 "this" 2 "that")) '(2 :str 3 :str)))
45
   ;; cond-bracket
46
   ;; (is (equal (mapcar ‹cond (#'evenp {+ 100}) (#'oddp {+ 200})› '(1 2 3 4)) '(201 102 203 104)))
47
   ;; if-bracket
48
   ;; (is (equal (mapcar ‹if #'evenp {list :a} {list :b}› '(1 2 3 4))
49
   ;; '((:b 1) (:a 2) (:b 3) (:a 4))))
50
   ;; when-bracket
51
   ;; (is (equal (mapcar ‹when 'evenp {+ 4}› '(1 2 3 4)) (list nil 6 nil 8)))
52
   ;; unless-bracket
53
   ;; (is (equal (mapcar ‹unless 'evenp {+ 4}› '(1 2 3 4)) (list 5 nil 7 nil)))
54
   )
55
 
56
 (deftest sym ()
57
   "Test standard symbol utils"
58
   ;; gensyms
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)))
62
 
63
 ;;;; TODO
64
 (deftest string ()
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))))
70
 
71
 (deftest list ()
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)))
76
   ;; different objects
77
   (is (not (eq (ensure-cons 0) (ensure-cons 0))))
78
   (is (equal (ensure-cons 0) (ensure-cons 0))))
79
 
80
 (deftest err ()
81
   "Test standard error handlers"
82
   (is (eql 'testing-err (deferror testing-err (std-error) nil (:auto t) (:documentation "testing")))))
83
 
84
 (deftest fmt ()
85
   "Test standard formatters"
86
   (is (string= (format nil "| 1 | 2 | 3 |~%") (fmt-row '(1 2 3))))
87
   (is (string= 
88
        ;; note the read-time-eval..
89
        #.(fmt-tree nil '(foobar (:a) (:b) (c) (d)) :layout :down)
90
        #"FOOBAR
91
  ├─ :A
92
  ├─ :B
93
  ├─  C
94
  ╰─  D
95
 "#))
96
   ;; with plist option
97
   (is (string= 
98
        #.(std:fmt-tree nil '(sk-project :name "foobar" :path "/a/b/c.asd" :vc :hg) :layout :down :plist t)
99
        #"SK-PROJECT
100
  ├─ :NAME
101
  │   ╰─ "foobar"
102
  ├─ :PATH
103
  │   ╰─ "/a/b/c.asd"
104
  ╰─ :VC
105
      ╰─ :HG
106
 "#)))
107
 
108
 (deftest ana ()
109
   "Test standard anaphoric macros"
110
   (is (= 8 
111
          (aif (+ 2 2)
112
               (+ it it))))
113
   (is (= 42 (awhen 42 it)))
114
   (is (= 3 (acond ((1+ 1) (1+ it)))))
115
   (loop for x in '(1 2 3)
116
         for y in (funcall (alet* ((a 1) (b 2) (c 3))
117
                                  (lambda () (mapc #'1+ (list a b c)))))
118
         collect (is (= x y))))
119
 
120
 (deftest pan ()
121
   "Test standard pandoric macros"
122
   (let ((p
123
           (plambda (a) (b c)
124
                    (if (not a)
125
                        (setq b 0
126
                              c 0)
127
                        (progn (incf b a) (incf c a))))))
128
     (with-pandoric (b c) p
129
       (is (= 0 (funcall p nil)))
130
       (is (= 1 (funcall p 1)))
131
       (is (= 11 (funcall p 10)))
132
       (is (= 0 (funcall p nil)))
133
       )))
134
 
135
 (deftest alien ()
136
   "Test standard alien utils"
137
   (is (= 0 (foreign-int-to-integer 0 4)))
138
   (is (= 1 (bool-to-foreign-int t)))
139
   (istype 
140
    '(alien (* (unsigned 8))) 
141
    (write-alien :octet-vector (std:make-octets 10) (make-alien unsigned-char 10))))
142
 
143
 (deftest curry ()
144
   "Test curry functions from Alexandria, found in std/fu.
145
 These tests are copied directly from the Alexandria test suite."
146
   ;; curry.1
147
   (let ((curried (curry '+ 3)))
148
     (is (= (funcall curried 1 5) 9)))
149
   ;; curry.2
150
   (let ((curried (locally (declare (notinline curry))
151
                    (curry '* 2 3))))
152
     (is (= (funcall curried 7) 42)))
153
   ;; curry.3
154
   (let ((curried-form (funcall (compiler-macro-function 'curry)
155
                                '(curry '/ 8)
156
                                nil)))
157
     (let ((fun (funcall (compile nil `(lambda () ,curried-form)))))
158
       (is (= (funcall fun 2) 4)))) ;; maybe fails?
159
   ;; curry.4
160
   (let* ((x 1)
161
          (curried (curry (progn
162
                            (incf x)
163
                            (lambda (y z) (* x y z)))
164
                          3)))
165
     (is (equal (list (funcall curried 7)
166
                      (funcall curried 7)
167
                      x)
168
                '(42 42 2))))
169
   ;; rcurry.1
170
   (let ((r (rcurry '/ 2)))
171
     (is (= (funcall r 8) 4)))
172
   ;; rcurry.2
173
   (let* ((x 1)
174
          (curried (rcurry (progn
175
                             (incf x)
176
                             (lambda (y z) (* x y z)))
177
                           3)))
178
     (is (equalp 
179
          (list (funcall curried 7) ;; 42
180
                (funcall curried 7) ;; 42
181
                x) ;; 2
182
          '(42 42 2)))))
183
 
184
 (define-bitfield testbits
185
   (a boolean)
186
   (b (signed-byte 2))
187
   (c (unsigned-byte 3) :initform 1)
188
   (d (integer -100 100))
189
   (e (member foo bar baz)))
190
 
191
 (deftest bits ()
192
   (let ((bits (make-testbits)))
193
     (is (not (testbits-a bits)))
194
     (is (= 0 (testbits-b bits)))
195
     (is (= 1 (testbits-c bits)))
196
     (is (= -100 (testbits-d bits)))
197
     (is (eql 'foo (testbits-e bits)))))
198
 ��������������������������������������������������������������������