logic-ops.scm 2.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106
  1. ;;; SPDX-License-Identifier: MIT
  2. ;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe
  3. (define (u1-not a)
  4. (- 1 a))
  5. (define (bitvector-not avec)
  6. (bitvector-map/int u1-not avec))
  7. (define (bitvector-not! avec)
  8. (bitvector-map!/int u1-not avec))
  9. (define (u1-and . args)
  10. (I (apply * args)))
  11. (define (bitvector-and . vecs)
  12. (apply bitvector-map/int u1-and vecs))
  13. (define (bitvector-and! . vecs)
  14. (apply bitvector-map!/int u1-and vecs))
  15. (define (u1-ior . args)
  16. (I (apply + args)))
  17. (define (bitvector-ior . vecs)
  18. (apply bitvector-map/int u1-ior vecs))
  19. (define (bitvector-ior! . vecs)
  20. (apply bitvector-map!/int u1-ior vecs))
  21. (define (u1-xor . args)
  22. (I (odd? (apply + args))))
  23. (define (bitvector-xor . vecs)
  24. (apply bitvector-map/int u1-xor vecs))
  25. (define (bitvector-xor! . vecs)
  26. (apply bitvector-map!/int u1-xor vecs))
  27. (define (u1-eqv . args)
  28. (let ((xor-value (apply u1-xor args)))
  29. (if (odd? (length args))
  30. xor-value
  31. (u1-not xor-value))))
  32. (define (bitvector-eqv . vecs)
  33. (apply bitvector-map/int u1-eqv vecs))
  34. (define (bitvector-eqv! . vecs)
  35. (apply bitvector-map!/int u1-eqv vecs))
  36. (define (u1-nand a b)
  37. (u1-not (u1-and a b)))
  38. (define (bitvector-nand a b)
  39. (bitvector-map/int u1-nand a b))
  40. (define (bitvector-nand! a b)
  41. (bitvector-map!/int u1-nand a b))
  42. (define (u1-nor a b)
  43. (u1-not (u1-ior a b)))
  44. (define (bitvector-nor a b)
  45. (bitvector-map/int u1-nor a b))
  46. (define (bitvector-nor! a b)
  47. (bitvector-map!/int u1-nor a b))
  48. (define (u1-andc1 a b)
  49. (u1-and (u1-not a) b))
  50. (define (bitvector-andc1 a b)
  51. (bitvector-map/int u1-andc1 a b))
  52. (define (bitvector-andc1! a b)
  53. (bitvector-map!/int u1-andc1 a b))
  54. (define (u1-andc2 a b)
  55. (u1-and a (u1-not b)))
  56. (define (bitvector-andc2 a b)
  57. (bitvector-map/int u1-andc2 a b))
  58. (define (bitvector-andc2! a b)
  59. (bitvector-map!/int u1-andc2 a b))
  60. (define (u1-orc1 a b)
  61. (u1-ior (u1-not a) b))
  62. (define (bitvector-orc1 a b)
  63. (bitvector-map/int u1-orc1 a b))
  64. (define (bitvector-orc1! a b)
  65. (bitvector-map!/int u1-orc1 a b))
  66. (define (u1-orc2 a b)
  67. (u1-ior a (u1-not b)))
  68. (define (bitvector-orc2 a b)
  69. (bitvector-map/int u1-orc2 a b))
  70. (define (bitvector-orc2! a b)
  71. (bitvector-map!/int u1-orc2 a b))