-
Notifications
You must be signed in to change notification settings - Fork 4
/
boole.lsp
150 lines (129 loc) · 4.4 KB
/
boole.lsp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Mon Sep 8 20:21:19 2003
;;;; Contains: Tests of BOOLE and associated constants
(in-package :cl-test)
(compile-and-load "numbers-aux.lsp")
(defparameter *boole-val-names*
'(boole-1 boole-2 boole-and boole-andc1 boole-andc2
boole-c1 boole-c2 boole-clr boole-eqv boole-ior
boole-nand boole-nor boole-orc1 boole-orc2 boole-set boole-xor))
(defparameter *boole-vals*
(list boole-1 boole-2 boole-and boole-andc1 boole-andc2
boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand
boole-nor boole-orc1 boole-orc2 boole-set boole-xor))
(defparameter *boole-fns*
(list #'(lambda (x y) (declare (ignore y)) x)
#'(lambda (x y) (declare (ignore x)) y)
#'logand
#'logandc1
#'logandc2
#'(lambda (x y) (declare (ignore y)) (lognot x))
#'(lambda (x y) (declare (ignore x)) (lognot y))
(constantly 0)
#'logeqv
#'logior
#'lognand
#'lognor
#'logorc1
#'logorc2
(constantly -1)
#'logxor))
(deftest boole.error.1
(signals-error (boole) program-error)
t)
(deftest boole.error.2
(signals-error (boole boole-1) program-error)
t)
(deftest boole.error.3
(signals-error (boole boole-1 1) program-error)
t)
(deftest boole.error.4
(signals-error (boole boole-1 1 2 nil) program-error)
t)
(deftest boole.error.5
(let ((bad (loop for i from 1 until (not (member i *boole-vals*)))))
(eval `(signals-type-error x ',bad (boole x 1 1))))
t)
(deftest boole.error.6
(loop for n in *boole-val-names*
unless (eval `(signals-type-error x nil (boole ,n nil 1)))
collect n)
nil)
(deftest boole.error.7
(loop for n in *boole-val-names*
unless (eval `(signals-type-error x nil (boole ,n 1 nil)))
collect n)
nil)
(deftest boole.1
(loop for v in *boole-vals*
for fn of-type function in *boole-fns*
for n in *boole-val-names*
nconc
(loop for x = (random-fixnum)
for y = (random-fixnum)
for result1 = (funcall (the function fn) x y)
for vals = (multiple-value-list (boole v x y))
for result2 = (car vals)
repeat 100
unless (and (= (length vals) 1) (eql result1 result2))
collect (list n x y result1 result2)))
nil)
(deftest boole.2
(loop for v in *boole-vals*
for fn of-type function in *boole-fns*
for n in *boole-val-names*
nconc
(loop for x = (random-from-interval 1000000000000000)
for y = (random-from-interval 1000000000000000)
for result1 = (funcall (the function fn) x y)
for vals = (multiple-value-list (boole v x y))
for result2 = (car vals)
repeat 100
unless (and (= (length vals) 1) (eql result1 result2))
collect (list n x y result1 result2)))
nil)
(deftest boole.3
(loop for n in *boole-val-names*
for fn of-type function in *boole-fns*
for fn2 = (compile nil `(lambda (x y) (declare (type fixnum x y))
(boole ,n x y)))
nconc
(loop for x = (random-fixnum)
for y = (random-fixnum)
for result1 = (funcall (the function fn) x y)
for vals = (multiple-value-list (funcall fn2 x y))
for result2 = (car vals)
repeat 100
unless (and (= (length vals) 1) (eql result1 result2))
collect (list n x y result1 result2)))
nil)
(deftest boole.4
(macrolet ((%m (z) z))
(values (boole (expand-in-current-env (%m boole-and)) #b11001100 #b01011010)
(boole boole-and (expand-in-current-env (%m #b11001100)) #b01011010)
(boole boole-and #b11001100 (expand-in-current-env (%m #b01011010)))))
#b01001000
#b01001000
#b01001000)
;;; Order of evaluation
(deftest boole.order.1
(let ((i 0) a b c)
(values
(boole
(progn (setf a (incf i)) boole-and)
(progn (setf b (incf i)) #b1101)
(progn (setf c (incf i)) #b11001))
i a b c))
#b1001 3 1 2 3)
;;; Constants are constants
(deftest boole.constants.1
(eqlt (length *boole-vals*)
(length (remove-duplicates *boole-vals*)))
t)
(deftest boole.constants.2
(remove-if #'constantp *boole-val-names*)
nil)
(deftest boole.constants.3
(remove-if #'boundp *boole-val-names*)
nil)