srfi-60.test 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483
  1. ;;;; srfi-60.test --- Test suite for Guile's SRFI-60 functions. -*- scheme -*-
  2. ;;;;
  3. ;;;; Copyright 2005, 2006 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. (define-module (test-srfi-60)
  19. #:duplicates (last) ;; avoid warning about srfi-60 replacing `bit-count'
  20. #:use-module (test-suite lib)
  21. #:use-module (srfi srfi-60))
  22. (pass-if "cond-expand srfi-60"
  23. (cond-expand (srfi-60 #t)
  24. (else #f)))
  25. ;;
  26. ;; logand
  27. ;;
  28. (with-test-prefix "logand"
  29. (pass-if (eqv? 6 (logand 14 6))))
  30. ;;
  31. ;; bitwise-and
  32. ;;
  33. (with-test-prefix "bitwise-and"
  34. (pass-if (eqv? 6 (bitwise-and 14 6))))
  35. ;;
  36. ;; logior
  37. ;;
  38. (with-test-prefix "logior"
  39. (pass-if (eqv? 14 (logior 10 12))))
  40. ;;
  41. ;; bitwise-ior
  42. ;;
  43. (with-test-prefix "bitwise-ior"
  44. (pass-if (eqv? 14 (bitwise-ior 10 12))))
  45. ;;
  46. ;; logxor
  47. ;;
  48. (with-test-prefix "logxor"
  49. (pass-if (eqv? 6 (logxor 10 12))))
  50. ;;
  51. ;; bitwise-xor
  52. ;;
  53. (with-test-prefix "bitwise-xor"
  54. (pass-if (eqv? 6 (bitwise-xor 10 12))))
  55. ;;
  56. ;; lognot
  57. ;;
  58. (with-test-prefix "lognot"
  59. (pass-if (eqv? -1 (lognot 0)))
  60. (pass-if (eqv? 0 (lognot -1))))
  61. ;;
  62. ;; bitwise-not
  63. ;;
  64. (with-test-prefix "bitwise-not"
  65. (pass-if (eqv? -1 (bitwise-not 0)))
  66. (pass-if (eqv? 0 (bitwise-not -1))))
  67. ;;
  68. ;; bitwise-if
  69. ;;
  70. (with-test-prefix "bitwise-if"
  71. (pass-if (eqv? 9 (bitwise-if 3 1 8)))
  72. (pass-if (eqv? 0 (bitwise-if 3 8 1))))
  73. ;;
  74. ;; bitwise-merge
  75. ;;
  76. (with-test-prefix "bitwise-merge"
  77. (pass-if (eqv? 9 (bitwise-merge 3 1 8)))
  78. (pass-if (eqv? 0 (bitwise-merge 3 8 1))))
  79. ;;
  80. ;; logtest
  81. ;;
  82. (with-test-prefix "logtest"
  83. (pass-if (eq? #t (logtest 3 6)))
  84. (pass-if (eq? #f (logtest 3 12))))
  85. ;;
  86. ;; any-bits-set?
  87. ;;
  88. (with-test-prefix "any-bits-set?"
  89. (pass-if (eq? #t (any-bits-set? 3 6)))
  90. (pass-if (eq? #f (any-bits-set? 3 12))))
  91. ;;
  92. ;; logcount
  93. ;;
  94. (with-test-prefix "logcount"
  95. (pass-if (eqv? 2 (logcount 12))))
  96. ;;
  97. ;; bit-count
  98. ;;
  99. (with-test-prefix "bit-count"
  100. (pass-if (eqv? 2 (bit-count 12))))
  101. ;;
  102. ;; integer-length
  103. ;;
  104. (with-test-prefix "integer-length"
  105. (pass-if (eqv? 0 (integer-length 0)))
  106. (pass-if (eqv? 8 (integer-length 128)))
  107. (pass-if (eqv? 8 (integer-length 255)))
  108. (pass-if (eqv? 9 (integer-length 256))))
  109. ;;
  110. ;; log2-binary-factors
  111. ;;
  112. (with-test-prefix "log2-binary-factors"
  113. (pass-if (eqv? -1 (log2-binary-factors 0)))
  114. (pass-if (eqv? 0 (log2-binary-factors 1)))
  115. (pass-if (eqv? 0 (log2-binary-factors 3)))
  116. (pass-if (eqv? 2 (log2-binary-factors 4)))
  117. (pass-if (eqv? 1 (log2-binary-factors 6)))
  118. (pass-if (eqv? 0 (log2-binary-factors -1)))
  119. (pass-if (eqv? 1 (log2-binary-factors -2)))
  120. (pass-if (eqv? 0 (log2-binary-factors -3)))
  121. (pass-if (eqv? 2 (log2-binary-factors -4)))
  122. (pass-if (eqv? 128 (log2-binary-factors #x100000000000000000000000000000000))))
  123. ;;
  124. ;; first-set-bit
  125. ;;
  126. (with-test-prefix "first-set-bit"
  127. (pass-if (eqv? -1 (first-set-bit 0)))
  128. (pass-if (eqv? 0 (first-set-bit 1)))
  129. (pass-if (eqv? 0 (first-set-bit 3)))
  130. (pass-if (eqv? 2 (first-set-bit 4)))
  131. (pass-if (eqv? 1 (first-set-bit 6)))
  132. (pass-if (eqv? 0 (first-set-bit -1)))
  133. (pass-if (eqv? 1 (first-set-bit -2)))
  134. (pass-if (eqv? 0 (first-set-bit -3)))
  135. (pass-if (eqv? 2 (first-set-bit -4))))
  136. ;;
  137. ;; logbit?
  138. ;;
  139. (with-test-prefix "logbit?"
  140. (pass-if (eq? #t (logbit? 0 1)))
  141. (pass-if (eq? #f (logbit? 1 1)))
  142. (pass-if (eq? #f (logbit? 1 8)))
  143. (pass-if (eq? #t (logbit? 1000 -1))))
  144. ;;
  145. ;; bit-set?
  146. ;;
  147. (with-test-prefix "bit-set?"
  148. (pass-if (eq? #t (bit-set? 0 1)))
  149. (pass-if (eq? #f (bit-set? 1 1)))
  150. (pass-if (eq? #f (bit-set? 1 8)))
  151. (pass-if (eq? #t (bit-set? 1000 -1))))
  152. ;;
  153. ;; copy-bit
  154. ;;
  155. (with-test-prefix "copy-bit"
  156. (pass-if (eqv? 0 (copy-bit 0 0 #f)))
  157. (pass-if (eqv? 0 (copy-bit 30 0 #f)))
  158. (pass-if (eqv? 0 (copy-bit 31 0 #f)))
  159. (pass-if (eqv? 0 (copy-bit 62 0 #f)))
  160. (pass-if (eqv? 0 (copy-bit 63 0 #f)))
  161. (pass-if (eqv? 0 (copy-bit 128 0 #f)))
  162. (pass-if (eqv? -1 (copy-bit 0 -1 #t)))
  163. (pass-if (eqv? -1 (copy-bit 30 -1 #t)))
  164. (pass-if (eqv? -1 (copy-bit 31 -1 #t)))
  165. (pass-if (eqv? -1 (copy-bit 62 -1 #t)))
  166. (pass-if (eqv? -1 (copy-bit 63 -1 #t)))
  167. (pass-if (eqv? -1 (copy-bit 128 -1 #t)))
  168. (pass-if (eqv? 1 (copy-bit 0 0 #t)))
  169. (pass-if (eqv? #x106 (copy-bit 8 6 #t)))
  170. (pass-if (eqv? 6 (copy-bit 8 6 #f)))
  171. (pass-if (eqv? -2 (copy-bit 0 -1 #f)))
  172. (pass-if "bignum becomes inum"
  173. (eqv? 0 (copy-bit 128 #x100000000000000000000000000000000 #f)))
  174. ;; bignums unchanged
  175. (pass-if (eqv? #x100000000000000000000000000000000
  176. (copy-bit 128 #x100000000000000000000000000000000 #t)))
  177. (pass-if (eqv? #x100000000000000000000000000000000
  178. (copy-bit 64 #x100000000000000000000000000000000 #f)))
  179. (pass-if (eqv? #x-100000000000000000000000000000000
  180. (copy-bit 64 #x-100000000000000000000000000000000 #f)))
  181. (pass-if (eqv? #x-100000000000000000000000000000000
  182. (copy-bit 256 #x-100000000000000000000000000000000 #t))))
  183. ;;
  184. ;; bit-field
  185. ;;
  186. (with-test-prefix "bit-field"
  187. (pass-if (eqv? 0 (bit-field 6 0 1)))
  188. (pass-if (eqv? 3 (bit-field 6 1 3)))
  189. (pass-if (eqv? 1 (bit-field 6 2 999)))
  190. (pass-if (eqv? 1 (bit-field #x100000000000000000000000000000000 128 129))))
  191. ;;
  192. ;; copy-bit-field
  193. ;;
  194. (with-test-prefix "copy-bit-field"
  195. (pass-if (eqv? #b111 (copy-bit-field #b110 1 0 1)))
  196. (pass-if (eqv? #b110 (copy-bit-field #b110 1 1 2)))
  197. (pass-if (eqv? #b010 (copy-bit-field #b110 1 1 3))))
  198. ;;
  199. ;; ash
  200. ;;
  201. (with-test-prefix "ash"
  202. (pass-if (eqv? 2 (ash 1 1)))
  203. (pass-if (eqv? 0 (ash 1 -1))))
  204. ;;
  205. ;; arithmetic-shift
  206. ;;
  207. (with-test-prefix "arithmetic-shift"
  208. (pass-if (eqv? 2 (arithmetic-shift 1 1)))
  209. (pass-if (eqv? 0 (arithmetic-shift 1 -1))))
  210. ;;
  211. ;; rotate-bit-field
  212. ;;
  213. (with-test-prefix "rotate-bit-field"
  214. (define-syntax-rule (check expected x count start end)
  215. (begin
  216. (pass-if-equal expected (rotate-bit-field x count start end))
  217. (pass-if-equal (lognot expected)
  218. (rotate-bit-field (lognot x) count start end))))
  219. (check #b110 #b110 1 1 2)
  220. (check #b1010 #b110 1 2 4)
  221. (check #b1011 #b0111 -1 1 4)
  222. (check #b0 #b0 128 0 256)
  223. (check #b1 #b1 128 1 256)
  224. (check #x100000000000000000000000000000000
  225. #x100000000000000000000000000000000 128 0 64)
  226. (check #x100000000000000000000000000000008
  227. #x100000000000000000000000000000001 3 0 64)
  228. (check #x100000000000000002000000000000000
  229. #x100000000000000000000000000000001 -3 0 64)
  230. (check #b110 #b110 0 0 10)
  231. (check #b110 #b110 0 0 256)
  232. (check #b110 #b110 1 1 1)
  233. (check #b10111010001100111101110010101
  234. #b11010001100111101110001110101 -26 5 28)
  235. (check #b11000110011110111000111011001
  236. #b11010001100111101110001110101 28 2 28)
  237. (check #b01111010001100111101110010101
  238. #b11010001100111101110001110101 -3 5 29)
  239. (check #b10100011001111011100011101101
  240. #b11010001100111101110001110101 28 2 29)
  241. (check #b110110100011001111011100010101
  242. #b011010001100111101110001110101 48 5 30)
  243. (check #b110100011001111011100011101001
  244. #b011010001100111101110001110101 85 2 30)
  245. (check #b011010001100111101110001110101
  246. #b110100011001111011100011101001 83 2 30)
  247. (check
  248. #b1101100110101001110000111110011010000111011101011101110111011
  249. #b1100110101001110000111110011010000111011101011101110110111011 -3 5 60)
  250. (check
  251. #b1011010100111000011111001101000011101110101110111011011101110
  252. #b1100110101001110000111110011010000111011101011101110110111011 62 0 60)
  253. (check
  254. #b1011100110101001110000111110011010000111011101011101110111011
  255. #b1100110101001110000111110011010000111011101011101110110111011 53 5 61)
  256. (check
  257. #b1001101010011100001111100110100001110111010111011101101110111
  258. #b1100110101001110000111110011010000111011101011101110110111011 62 0 61)
  259. (check
  260. #b11011001101010011100001111100110100001110111010111011100111011
  261. #b01100110101001110000111110011010000111011101011101110110111011 53 7 62)
  262. (check
  263. #b11011001101010011100001111100110100001110111010111011100111011
  264. #b01100110101001110000111110011010000111011101011101110110111011 -2 7 62)
  265. (check
  266. #b01100110101001110000111110011010000111011101011101110110111011
  267. #b11011001101010011100001111100110100001110111010111011100111011 2 7 62)
  268. (pass-if-equal "bignum becomes inum"
  269. 1
  270. (rotate-bit-field #x100000000000000000000000000000000 1 0 129)))
  271. ;;
  272. ;; reverse-bit-field
  273. ;;
  274. (with-test-prefix "reverse-bit-field"
  275. (pass-if (eqv? 6 (reverse-bit-field 6 1 3)))
  276. (pass-if (eqv? 12 (reverse-bit-field 6 1 4)))
  277. (pass-if (eqv? #x80000000 (reverse-bit-field 1 0 32)))
  278. (pass-if (eqv? #x40000000 (reverse-bit-field 1 0 31)))
  279. (pass-if (eqv? #x20000000 (reverse-bit-field 1 0 30)))
  280. (pass-if (eqv? (logior (ash -1 32) #xFBFFFFFF)
  281. (reverse-bit-field -2 0 27)))
  282. (pass-if (eqv? (logior (ash -1 32) #xF7FFFFFF)
  283. (reverse-bit-field -2 0 28)))
  284. (pass-if (eqv? (logior (ash -1 32) #xEFFFFFFF)
  285. (reverse-bit-field -2 0 29)))
  286. (pass-if (eqv? (logior (ash -1 32) #xDFFFFFFF)
  287. (reverse-bit-field -2 0 30)))
  288. (pass-if (eqv? (logior (ash -1 32) #xBFFFFFFF)
  289. (reverse-bit-field -2 0 31)))
  290. (pass-if (eqv? (logior (ash -1 32) #x7FFFFFFF)
  291. (reverse-bit-field -2 0 32)))
  292. (pass-if "bignum becomes inum"
  293. (eqv? 5 (reverse-bit-field #x140000000000000000000000000000000 0 129))))
  294. ;;
  295. ;; integer->list
  296. ;;
  297. (with-test-prefix "integer->list"
  298. (pass-if (equal? '(#t #t #f) (integer->list 6)))
  299. (pass-if (equal? '(#f #t #t #f) (integer->list 6 4)))
  300. (pass-if (equal? '(#t #f) (integer->list 6 2)))
  301. (pass-if "zeros above top of positive inum"
  302. (equal? '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  303. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  304. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  305. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  306. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  307. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  308. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  309. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t)
  310. (integer->list 1 128)))
  311. (pass-if "ones above top of negative inum"
  312. (equal? '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
  313. #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
  314. #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
  315. #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
  316. #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
  317. #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
  318. #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
  319. #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)
  320. (integer->list -1 128)))
  321. (pass-if (equal? '(#t
  322. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  323. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  324. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  325. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  326. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  327. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  328. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  329. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)
  330. (integer->list #x100000000000000000000000000000000))))
  331. ;;
  332. ;; list->integer
  333. ;;
  334. (with-test-prefix "list->integer"
  335. (pass-if (eqv? 6 (list->integer '(#t #t #f))))
  336. (pass-if (eqv? 6 (list->integer '(#f #t #t #f))))
  337. (pass-if (eqv? 2 (list->integer '(#t #f))))
  338. (pass-if "leading #f's"
  339. (eqv? 1 (list->integer
  340. '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  341. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  342. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  343. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  344. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  345. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  346. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  347. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t))))
  348. (pass-if (eqv? #x100000000000000000000000000000000
  349. (list->integer
  350. '(#t
  351. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  352. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  353. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  354. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  355. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  356. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  357. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  358. #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))))
  359. (pass-if (eqv? #x03FFFFFF (list->integer '(#t #t
  360. #t #t #t #t #t #t #t #t
  361. #t #t #t #t #t #t #t #t
  362. #t #t #t #t #t #t #t #t))))
  363. (pass-if (eqv? #x07FFFFFF (list->integer '(#t #t #t
  364. #t #t #t #t #t #t #t #t
  365. #t #t #t #t #t #t #t #t
  366. #t #t #t #t #t #t #t #t))))
  367. (pass-if (eqv? #x0FFFFFFF (list->integer '(#t #t #t #t
  368. #t #t #t #t #t #t #t #t
  369. #t #t #t #t #t #t #t #t
  370. #t #t #t #t #t #t #t #t))))
  371. (pass-if (eqv? #x1FFFFFFF (list->integer '(#t #t #t #t #t
  372. #t #t #t #t #t #t #t #t
  373. #t #t #t #t #t #t #t #t
  374. #t #t #t #t #t #t #t #t))))
  375. (pass-if (eqv? #x3FFFFFFF (list->integer '(#t #t #t #t #t #t
  376. #t #t #t #t #t #t #t #t
  377. #t #t #t #t #t #t #t #t
  378. #t #t #t #t #t #t #t #t))))
  379. (pass-if (eqv? #x7FFFFFFF (list->integer '(#t #t #t #t #t #t #t
  380. #t #t #t #t #t #t #t #t
  381. #t #t #t #t #t #t #t #t
  382. #t #t #t #t #t #t #t #t))))
  383. (pass-if (eqv? #xFFFFFFFF (list->integer '(#t #t #t #t #t #t #t #t
  384. #t #t #t #t #t #t #t #t
  385. #t #t #t #t #t #t #t #t
  386. #t #t #t #t #t #t #t #t))))
  387. (pass-if (eqv? #x1FFFFFFFF (list->integer '(#t
  388. #t #t #t #t #t #t #t #t
  389. #t #t #t #t #t #t #t #t
  390. #t #t #t #t #t #t #t #t
  391. #t #t #t #t #t #t #t #t)))))
  392. ;;
  393. ;; list->integer
  394. ;;
  395. (with-test-prefix "list->integer"
  396. (pass-if (eqv? 0 (booleans->integer)))
  397. (pass-if (eqv? 6 (booleans->integer #t #t #f))))