--- a/Makefile Wed Jul 13 23:36:51 2016 +0000
+++ b/Makefile Thu Jul 14 13:30:57 2016 +0000
@@ -1,19 +1,28 @@
-.PHONY: test pubdocs bench profile
+.PHONY: test pubdocs bench profile test-sbcl test-ccl test-ecl
sourcefiles = $(shell ffind --full-path --dir src --literal .lisp)
docfiles = $(shell ls docs/*.markdown)
apidoc = docs/03-reference.markdown
-test:
- figlet -kf big 'SBCL'
+test: test-sbcl test-ccl test-ecl
+
+test-sbcl:
+ echo; figlet -kf computer 'SBCL' | sed -Ee 's/ +$$//' | tr -s '\n' | lolcat --freq=0.25; echo
ros run -L sbcl --load test/run.lisp
- figlet -kf big 'CCL'
+test-ccl:
+ echo; figlet -kf slant 'CCL' | sed -Ee 's/ +$$//' | tr -s '\n' | lolcat --freq=0.25; echo
ros run -L ccl-bin --load test/run.lisp
+test-ecl:
+ echo; figlet -kf roman 'ECL' | sed -Ee 's/ +$$//' | tr -s '\n' | lolcat --freq=0.25; echo
+ ros run -L ecl --load test/run.lisp
+
+
src/quickutils.lisp: src/make-quickutils.lisp
cd src && sbcl-rlwrap --noinform --load make-quickutils.lisp --eval '(quit)'
+
$(apidoc): $(sourcefiles) docs/api.lisp
sbcl-rlwrap --noinform --load docs/api.lisp --eval '(quit)'
@@ -28,6 +37,7 @@
hg -R ~/src/sjl.bitbucket.org commit -Am 'bones: Update site.'
hg -R ~/src/sjl.bitbucket.org push
+
bench:
sbcl-rlwrap --noinform --load examples/bench.lisp --eval '(quit)'
--- a/bones-test.asd Wed Jul 13 23:36:51 2016 +0000
+++ b/bones-test.asd Thu Jul 14 13:30:57 2016 +0000
@@ -3,7 +3,7 @@
:author "Steve Losh <steve@stevelosh.com>"
:license "MIT/X11"
:depends-on (#:bones
- #:fiveam)
+ #:1am)
:serial t
:components ((:file "package-test")
(:module "test"
--- a/package-test.lisp Wed Jul 13 23:36:51 2016 +0000
+++ b/package-test.lisp Thu Jul 14 13:30:57 2016 +0000
@@ -1,23 +1,20 @@
(defpackage #:bones-test
(:use
#:cl
- #:5am
+ #:1am
))
(defpackage #:bones-test.paip
(:use
#:cl
- #:5am
+ #:1am
#:bones.quickutils
- #:bones.paip)
- ; kill me
- (:shadowing-import-from #:5am
- #:fail))
+ #:bones.paip))
(defpackage #:bones-test.wam
(:use
#:cl
- #:5am
+ #:1am
#:bones.quickutils
#:bones.wam)
(:import-from #:bones.wam
@@ -39,4 +36,4 @@
#:!))
(defpackage #:bones-test.circle
- (:use :cl :5am :bones.circle))
+ (:use :cl :1am :bones.circle))
--- a/test/bones.lisp Wed Jul 13 23:36:51 2016 +0000
+++ b/test/bones.lisp Thu Jul 14 13:30:57 2016 +0000
@@ -1,5 +1,1 @@
(in-package #:bones-test)
-
-(def-suite :bones)
-(in-suite :bones)
-
--- a/test/circle.lisp Wed Jul 13 23:36:51 2016 +0000
+++ b/test/circle.lisp Thu Jul 14 13:30:57 2016 +0000
@@ -1,19 +1,16 @@
(in-package #:bones-test.circle)
-(def-suite :bones.circle)
-(in-suite :bones.circle)
-
(defmacro is-circle-contents (circle values)
`(is (equal ,values
(circle-to-list ,circle))))
(test empty-circles
- (is-true (circle-empty-p (make-empty-circle)))
- (is-true (circle-empty-p (make-circle-with nil)))
- (is-false (circle-empty-p (make-circle-with (list 1)))))
+ (is (circle-empty-p (make-empty-circle)))
+ (is (circle-empty-p (make-circle-with nil)))
+ (is (not (circle-empty-p (make-circle-with (list 1))))))
-(test make-circle-with
+(test making-circle-with
(is-circle-contents
(make-circle-with (list))
nil)
@@ -68,7 +65,7 @@
(is-circle-contents c '(a b 1 p q))))
-(test forward
+(test moving-forward
(let ((c (make-circle-with (list 1 2 3 4))))
(is (equal
'(1 2 3 4)
@@ -76,7 +73,7 @@
:while node
:collect (circle-value node))))))
-(test backward
+(test moving-backward
(let ((c (make-circle-with (list 1 2 3 4))))
(is (equal
'(4 3 2 1)
@@ -85,7 +82,7 @@
:collect (circle-value node))))))
-(test rotate
+(test rotating
(let ((c (make-circle-with (list 1 2 3 4))))
(is-circle-contents (circle-rotate c 0)
'(1 2 3 4))
@@ -118,7 +115,8 @@
(is-circle-contents (circle-rotate (circle-rotate c 3) -1)
'(2 3 4 1))))
-(test nth
+
+(test retrieving-nth
(let* ((data (list 'a 'b 'c 'd))
(c (make-circle-with data)))
(loop :for i :from 0 :below 4
@@ -126,7 +124,7 @@
:do (is (eql v (circle-value (circle-nth c i)))))))
-(test insert-before
+(test inserting-before
(let ((c (make-circle-with (list 1 2 3))))
(circle-insert-before c 'a)
(is-circle-contents c '(1 2 3 a))
@@ -143,7 +141,7 @@
(circle-insert-before (circle-nth c -1) 'e)
(is-circle-contents c '(b c d 1 2 3 e a))))
-(test insert-after
+(test inserting-after
(let ((c (make-circle-with (list 1 2 3))))
(circle-insert-after c 'a)
(is-circle-contents c '(a 1 2 3))
@@ -161,19 +159,19 @@
(is-circle-contents c '(a b c d 1 2 3 x))))
-(test sentinel-p
+(test checking-sentinel
(let ((c (make-circle-with (list 1 2 3))))
- (is-true (circle-sentinel-p c))
- (is-false (circle-sentinel-p (circle-nth c 0)))
- (is-false (circle-sentinel-p (circle-nth c 1)))
- (is-false (circle-sentinel-p (circle-nth c 2)))
- (is-true (circle-sentinel-p (circle-nth c 3))))
- (is-true (circle-sentinel-p (make-empty-circle)))
- (is-true (circle-sentinel-p (circle-nth (make-empty-circle) 0)))
- (is-true (circle-sentinel-p (circle-nth (make-empty-circle) -1))))
+ (is (circle-sentinel-p c))
+ (is (not (circle-sentinel-p (circle-nth c 0))))
+ (is (not (circle-sentinel-p (circle-nth c 1))))
+ (is (not (circle-sentinel-p (circle-nth c 2))))
+ (is (circle-sentinel-p (circle-nth c 3))))
+ (is (circle-sentinel-p (make-empty-circle)))
+ (is (circle-sentinel-p (circle-nth (make-empty-circle) 0)))
+ (is (circle-sentinel-p (circle-nth (make-empty-circle) -1))))
-(test remove
+(test removing
(let ((c (make-circle-with (list 1 2 3))))
(signals simple-error (circle-remove c))
(is-circle-contents c '(1 2 3))
@@ -187,14 +185,14 @@
(circle-remove (circle-nth c 0))
(is-circle-contents c '())))
-(test backward-remove
+(test removing-backward
(let ((c (make-circle-with (list 1 2 3 4 5 6))))
(is-circle-contents c '(1 2 3 4 5 6))
(is-circle-contents (circle-backward-remove (circle-nth c 1))
'(1 3 4 5 6))
- (is-false (circle-backward-remove (circle-nth c 0)))
+ (is (not (circle-backward-remove (circle-nth c 0))))
(is-circle-contents c '(3 4 5 6))
(is-circle-contents (circle-backward-remove (circle-nth c -1))
@@ -202,18 +200,18 @@
(is-circle-contents c '(3 4 5))))
-(test forward-remove
+(test removing-forward
(let ((c (make-circle-with (list 1 2 3 4 5 6))))
(is-circle-contents c '(1 2 3 4 5 6))
(is-circle-contents (circle-forward-remove (circle-nth c 1))
'(3 4 5 6 1))
- (is-false (circle-forward-remove (circle-nth c -1)))
+ (is (not (circle-forward-remove (circle-nth c -1))))
(is-circle-contents c '(1 3 4 5))))
-(test replace
+(test replacing
(let ((c (make-circle-with (list 1 2 3 4 5 6))))
(is-circle-contents c '(1 2 3 4 5 6))
@@ -232,7 +230,7 @@
(circle-replace (circle-nth c -1) 'c)
(is-circle-contents c '(bar a b 4 5 c))))
-(test backward-replace
+(test replacing-backward
(let ((c (make-circle-with (list 1 2 3 4 5 6))))
(is-circle-contents c '(1 2 3 4 5 6))
@@ -245,10 +243,10 @@
(is-circle-contents (circle-backward-replace (circle-nth c 2) 'a)
'(bar a 4 5 6 1))
- (is-false (circle-backward-replace (circle-nth c 0) 'dogs))
+ (is (not (circle-backward-replace (circle-nth c 0) 'dogs)))
(is-circle-contents c '(dogs bar a 4 5 6))))
-(test forward-replace
+(test replacing-forward
(let ((c (make-circle-with (list 1 2 3 4 5 6))))
(is-circle-contents c '(1 2 3 4 5 6))
@@ -258,11 +256,11 @@
(is-circle-contents (circle-forward-replace (circle-nth c 1) 'bar)
'(3 4 5 6 1 bar))
- (is-false (circle-forward-replace (circle-nth c -1) 'cats))
+ (is (not (circle-forward-replace (circle-nth c -1) 'cats)))
(is-circle-contents c '(1 bar 3 4 5 cats))))
-(test splice
+(test splicing
(let ((c (make-circle-with (list 1 2 3 4 5 6))))
(is-circle-contents c '(1 2 3 4 5 6))
@@ -278,7 +276,7 @@
(circle-splice (circle-nth c 3) nil)
(is-circle-contents c '(a c 2 4 5 dogs cats))))
-(test backward-splice
+(test splicing-backward
(let ((c (make-circle-with (list 1 2 3 4 5 6))))
(is-circle-contents c '(1 2 3 4 5 6))
@@ -288,10 +286,10 @@
(is-circle-contents (circle-backward-splice (circle-nth c -1) '())
'(5 1 2 a b 4))
- (is-false (circle-backward-splice (circle-nth c 0) '(first second)))
+ (is (not (circle-backward-splice (circle-nth c 0) '(first second))))
(is-circle-contents c '(first second 2 a b 4 5))))
-(test forward-splice
+(test splicing-forward
(let ((c (make-circle-with (list 1 2 3 4 5 6))))
(is-circle-contents c '(1 2 3 4 5 6))
@@ -301,5 +299,5 @@
(is-circle-contents (circle-forward-splice (circle-nth c 1) '())
'(2 3 4 5 6 a))
- (is-false (circle-forward-splice (circle-nth c -1) '(last)))
+ (is (not (circle-forward-splice (circle-nth c -1) '(last))))
(is-circle-contents c '(a 2 3 4 5 last))))
--- a/test/paip.lisp Wed Jul 13 23:36:51 2016 +0000
+++ b/test/paip.lisp Thu Jul 14 13:30:57 2016 +0000
@@ -1,9 +1,5 @@
(in-package #:bones-test.paip)
-(def-suite :bones.paip)
-(in-suite :bones.paip)
-
-
;;;; Utils
(defun alist-equal (x y)
(set-equal x y :test #'equal))
@@ -27,10 +23,10 @@
(defmacro proves (query)
- `(is-true (return-all ,query)))
+ `(is (return-all ,query)))
(defmacro not-proves (query)
- `(is-false (return-all ,query)))
+ `(is (not (return-all ,query))))
(defmacro proves-with (query results)
`(is (set-equal ',results (return-all ,query)
--- a/test/run.lisp Wed Jul 13 23:36:51 2016 +0000
+++ b/test/run.lisp Thu Jul 14 13:30:57 2016 +0000
@@ -1,24 +1,19 @@
+#+ecl (setf compiler:*user-cc-flags* "-Wno-shift-negative-value")
+
(declaim (optimize (debug 3) (safety 3) (speed 0)))
+
(let ((*standard-output* (make-broadcast-stream))
(*error-output* (make-broadcast-stream)))
(asdf:load-system 'bones :force t)
(ql:quickload "bones-test"))
-
-(defvar *passed* t)
-
-(defun test (spec)
- (let ((result (5am:run spec)))
- (5am:explain! result)
- (when (not (5am:results-status result))
- (setf *passed* nil))))
+(defun done (exit-code)
+ #+sbcl (sb-ext:exit :code exit-code)
+ #+ccl (quit exit-code)
+ #+ecl (quit exit-code))
-(test :bones)
-(test :bones.paip)
-(test :bones.wam)
-(test :bones.circle)
-(let ((exit-code (if *passed* 0 1)))
- #+sbcl (sb-ext:exit :code exit-code)
- #+ccl (quit exit-code))
+(time (progn (1am:run) (terpri)))
+(terpri)
+(done 0)
--- a/test/wam.lisp Wed Jul 13 23:36:51 2016 +0000
+++ b/test/wam.lisp Thu Jul 14 13:30:57 2016 +0000
@@ -1,9 +1,5 @@
(in-package #:bones-test.wam)
-(def-suite :bones.wam)
-(in-suite :bones.wam)
-
-
;;;; Setup
(defun make-test-database ()
(let ((db (make-database)))
@@ -166,7 +162,7 @@
(?x cats)
(?x (f dogs))))))
-(test not
+(test negation
(with-fresh-database
(push-logic-frame-with
(fact (yes ?anything))