From a3a3f45f2473649d64411e6e099c533c6c309fdd Mon Sep 17 00:00:00 2001 From: Stelian Ionescu Date: Sat, 21 Apr 2012 16:44:52 +0200 Subject: [PATCH] Drop dependency on Arnesi, use Alexandria instead Disable collection of profiling info until a portable library can be used --- fiveam.asd | 49 ++++++------ src/check.lisp | 6 +- src/fixture.lisp | 19 ++++- src/packages.lisp | 2 +- src/random.lisp | 2 +- src/run.lisp | 11 ++- src/suite.lisp | 4 +- src/test.lisp | 15 +++- src/utils.lisp | 223 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 9 files changed, 289 insertions(+), 42 deletions(-) create mode 100644 src/utils.lisp diff --git a/fiveam.asd b/fiveam.asd index 7c16a78..22f118f 100644 --- a/fiveam.asd +++ b/fiveam.asd @@ -1,33 +1,30 @@ ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- -(defpackage :it.bese.FiveAM.system - (:use :common-lisp - :asdf)) (defsystem :fiveam + :author "Edward Marco Baringer " + :depends-on (:alexandria) + :pathname "src/" + :components ((:file "packages") + (:file "utils" :depends-on ("packages")) + (:file "check" :depends-on ("packages" "utils")) + (:file "fixture" :depends-on ("packages")) + (:file "classes" :depends-on ("packages")) + (:file "random" :depends-on ("packages" "check")) + (:file "test" :depends-on ("packages" "fixture" "classes")) + (:file "explain" :depends-on ("packages" "utils" "check" "classes" "random")) + (:file "suite" :depends-on ("packages" "test" "classes")) + (:file "run" :depends-on ("packages" "check" "classes" "test" "explain" "suite"))) + :in-order-to ((test-op (load-op :fiveam-test))) + :perform (test-op :after (op c) + (funcall (intern (string '#:run!) :it.bese.fiveam) + :it.bese.fiveam))) -(in-package :it.bese.FiveAM.system) - - :author "Edward Marco Baringer " - :properties ((:test-suite-name . :it.bese.fiveam)) - :components ((:static-file "fiveam.asd") - (:module :src - :components ((:file "check" :depends-on ("packages")) - (:file "classes" :depends-on ("packages")) - (:file "explain" :depends-on ("classes" "packages" "check")) - (:file "fixture" :depends-on ("packages")) - (:file "packages") - (:file "run" :depends-on ("packages" "classes" "test" "suite" "check")) - (:file "suite" :depends-on ("packages" "test" "classes")) - (:file "random" :depends-on ("packages" "check")) - (:file "test" :depends-on ("packages" "classes")))) - (:module :t - :components ((:file "suite") - (:file "tests" :depends-on ("suite"))) - :depends-on (:src))) - :depends-on (:arnesi)) - -(defmethod asdf:perform ((op asdf:test-op) (system (eql (find-system :FiveAM)))) - (funcall (intern (string :run!) (string :it.bese.FiveAM)) :it.bese.FiveAM)) +(defsystem :fiveam-test + :author "Edward Marco Baringer " + :depends-on (:fiveam) + :pathname "t/" + :components ((:file "suite") + (:file "tests" :depends-on ("suite")))) ;;;;@include "src/packages.lisp" diff --git a/src/check.lisp b/src/check.lisp index efac176..39e9f4f 100644 --- a/src/check.lisp +++ b/src/check.lisp @@ -127,7 +127,7 @@ REASON-ARGS is provided, is generated based on the form of TEST: (test) "Argument to IS must be a list, not ~S" test) (let (bindings effective-test default-reason-args) - (with-unique-names (e a v) + (with-gensyms (e a v) (flet ((process-entry (predicate expected actual &optional negatedp) ;; make sure EXPECTED is holding the entry that starts with 'values (when (and (consp actual) @@ -229,8 +229,8 @@ REASON-ARGS is provided, is generated based on the form of TEST: failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does not inspect CONDITION to determine what reason to give it case of test failure" - - (with-unique-names (value) + + (with-gensyms (value) `(let ((,value ,condition)) (if ,value (process-failure diff --git a/src/fixture.lisp b/src/fixture.lisp index 07423ad..2f559ec 100644 --- a/src/fixture.lisp +++ b/src/fixture.lisp @@ -13,10 +13,25 @@ ;;;; 'fixture' is so common in testing frameworks we've provided a ;;;; wrapper around defmacro for this purpose. -(deflookup-table fixture - :documentation "Lookup table mapping fixture names to fixture +(defvar *fixture* + (make-hash-table :test 'eql) + "Lookup table mapping fixture names to fixture objects.") +(defun get-fixture (key &optional default) + (gethash key *fixture* default)) + +(defun (setf get-fixture) (value key) + (when (gethash key *fixture*) + (warn "Redefining ~A in deflookup-table named ~S" + (let ((*package* (find-package :keyword))) + (format nil "~S" key)) + 'fixture)) + (setf (gethash key *fixture*) value)) + +(defun rem-fixture (key) + (remhash key *fixture*)) + (defmacro def-fixture (name args &body body) "Defines a fixture named NAME. A fixture is very much like a macro but is used only for simple templating. A fixture created diff --git a/src/packages.lisp b/src/packages.lisp index 3628150..1730788 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -17,8 +17,8 @@ ;;;; developer to quickly and easily redefine, change, remove and run ;;;; tests. - (:use :common-lisp :it.bese.arnesi) (defpackage :it.bese.fiveam + (:use :common-lisp :alexandria) (:nicknames :5am :fiveam) (:export ;; creating tests and test-suites diff --git a/src/random.lisp b/src/random.lisp index b9bf4e7..07b5eb9 100644 --- a/src/random.lisp +++ b/src/random.lisp @@ -66,7 +66,7 @@ Examples: (for-all (((a b) (gen-two-integers))) (is (integerp a)) (is (integerp b)))" - (with-unique-names (test-lambda-args) + (with-gensyms (test-lambda-args) `(perform-random-testing (list ,@(mapcar #'second bindings)) (lambda (,test-lambda-args) diff --git a/src/run.lisp b/src/run.lisp index 50697fc..c81aba4 100644 --- a/src/run.lisp +++ b/src/run.lisp @@ -154,8 +154,9 @@ run.")) (let ((*readtable* (copy-readtable)) (*package* (runtime-package test))) (if (collect-profiling-info test) - (setf (profiling-info test) - (arnesi:collect-timing (test-lambda test))) + ;; Timing info doesn't get collected ATM, we need a portable library + ;; (setf (profiling-info test) (collect-timing (test-lambda test))) + (funcall (test-lambda test)) (funcall (test-lambda test)))) (retest () :report (lambda (stream) @@ -192,7 +193,9 @@ run.")) (bind-run-state ((result-list '())) (unwind-protect (if (collect-profiling-info suite) - (setf (profiling-info suite) (collect-timing #'run-tests)) + ;; Timing info doesn't get collected ATM, we need a portable library + ;; (setf (profiling-info suite) (collect-timing #'run-tests)) + (run-tests) (run-tests))) (setf suite-results result-list (status suite) (every (lambda (res) @@ -202,7 +205,7 @@ run.")) (setf result-list (nconc result-list suite-results))))))) (defmethod %run ((test-name symbol)) - (when-bind test (get-test test-name) + (when-let (test (get-test test-name)) (%run test))) (defvar *initial-!* (lambda () (format t "Haven't run that many tests yet.~%"))) diff --git a/src/suite.lisp b/src/suite.lisp index eb2691d..5928227 100644 --- a/src/suite.lisp +++ b/src/suite.lisp @@ -72,9 +72,9 @@ See also: DEF-SUITE *SUITE*" `(%in-suite ,suite-name :in ,in :fail-on-error nil)) (defmacro %in-suite (suite-name &key (fail-on-error t) in) - (with-unique-names (suite) + (with-gensyms (suite) `(progn - (if-bind ,suite (get-test ',suite-name) + (if-let (,suite (get-test ',suite-name)) (setf *suite* ,suite) (progn (when ,fail-on-error diff --git a/src/test.lisp b/src/test.lisp index ab0feeb..9c52a0b 100644 --- a/src/test.lisp +++ b/src/test.lisp @@ -11,11 +11,20 @@ ;;;; collection of checks which can be run and a test suite is a named ;;;; collection of tests and test suites. -(deflookup-table test - :at-redefinition nil - :documentation "Lookup table mapping test (and test suite) +(defvar *test* + (make-hash-table :test 'eql) + "Lookup table mapping test (and test suite) names to objects.") +(defun get-test (key &optional default) + (gethash key *test* default)) + +(defun (setf get-test) (value key) + (setf (gethash key *test*) value)) + +(defun rem-test (key) + (remhash key *test*)) + (defun test-names () (loop for test being the hash-keys of *test* collect test)) diff --git a/src/utils.lisp b/src/utils.lisp new file mode 100644 index 0000000..05a7c5f --- /dev/null +++ b/src/utils.lisp @@ -0,0 +1,223 @@ +;; -*- lisp -*- + +(in-package :it.bese.fiveam) + +(defmacro dolist* ((iterator list &optional return-value) &body body) + "Like DOLIST but destructuring-binds the elements of LIST. + +If ITERATOR is a symbol then dolist* is just like dolist EXCEPT +that it creates a fresh binding." + (if (listp iterator) + (let ((i (gensym "DOLIST*-I-"))) + `(dolist (,i ,list ,return-value) + (destructuring-bind ,iterator ,i + ,@body))) + `(dolist (,iterator ,list ,return-value) + (let ((,iterator ,iterator)) + ,@body)))) + +(defun make-collector (&optional initial-value) + "Create a collector function. + +A Collector function will collect, into a list, all the values +passed to it in the order in which they were passed. If the +callector function is called without arguments it returns the +current list of values." + (let ((value initial-value) + (cdr (last initial-value))) + (lambda (&rest items) + (if items + (progn + (if value + (if cdr + (setf (cdr cdr) items + cdr (last items)) + (setf cdr (last items))) + (setf value items + cdr (last items))) + items) + value)))) + +(defun partitionx (list &rest lambdas) + (let ((collectors (mapcar (lambda (l) + (cons (if (and (symbolp l) + (member l (list :otherwise t) + :test #'string=)) + (constantly t) + l) + (make-collector))) + lambdas))) + (dolist (item list) + (block item + (dolist* ((test-func . collector-func) collectors) + (when (funcall test-func item) + (funcall collector-func item) + (return-from item))))) + (mapcar #'funcall (mapcar #'cdr collectors)))) + +;;;; ** Anaphoric conditionals + +(defmacro if-bind (var test &body then/else) + "Anaphoric IF control structure. + +VAR (a symbol) will be bound to the primary value of TEST. If +TEST returns a true value then THEN will be executed, otherwise +ELSE will be executed." + (assert (first then/else) + (then/else) + "IF-BIND missing THEN clause.") + (destructuring-bind (then &optional else) + then/else + `(let ((,var ,test)) + (if ,var ,then ,else)))) + +(defmacro aif (test then &optional else) + "Just like IF-BIND but the var is always IT." + `(if-bind it ,test ,then ,else)) + +;;;; ** Simple list matching based on code from Paul Graham's On Lisp. + +(defmacro acond2 (&rest clauses) + (if (null clauses) + nil + (with-gensyms (val foundp) + (destructuring-bind ((test &rest progn) &rest others) + clauses + `(multiple-value-bind (,val ,foundp) + ,test + (if (or ,val ,foundp) + (let ((it ,val)) + (declare (ignorable it)) + ,@progn) + (acond2 ,@others))))))) + +(defun varsymp (x) + (and (symbolp x) (eq (aref (symbol-name x) 0) #\?))) + +(defun binding (x binds) + (labels ((recbind (x binds) + (aif (assoc x binds) + (or (recbind (cdr it) binds) + it)))) + (let ((b (recbind x binds))) + (values (cdr b) b)))) + +(defun list-match (x y &optional binds) + (acond2 + ((or (eql x y) (eql x '_) (eql y '_)) + (values binds t)) + ((binding x binds) (list-match it y binds)) + ((binding y binds) (list-match x it binds)) + ((varsymp x) (values (cons (cons x y) binds) t)) + ((varsymp y) (values (cons (cons y x) binds) t)) + ((and (consp x) (consp y) (list-match (car x) (car y) binds)) + (list-match (cdr x) (cdr y) it)) + (t (values nil nil)))) + +(defun vars (match-spec) + (let ((vars nil)) + (labels ((find-vars (spec) + (cond + ((null spec) nil) + ((varsymp spec) (push spec vars)) + ((consp spec) + (find-vars (car spec)) + (find-vars (cdr spec)))))) + (find-vars match-spec)) + (delete-duplicates vars))) + +(defmacro list-match-case (target &body clauses) + (if clauses + (destructuring-bind ((test &rest progn) &rest others) + clauses + (with-gensyms (tgt binds success) + `(let ((,tgt ,target)) + (multiple-value-bind (,binds ,success) + (list-match ,tgt ',test) + (declare (ignorable ,binds)) + (if ,success + (let ,(mapcar (lambda (var) + `(,var (cdr (assoc ',var ,binds)))) + (vars test)) + (declare (ignorable ,@(vars test))) + ,@progn) + (list-match-case ,tgt ,@others)))))) + nil)) + +;;;; * def-special-environment + +(defun check-required (name vars required) + (dolist (var required) + (assert (member var vars) + (var) + "Unrecognized symbol ~S in ~S." var name))) + +(defmacro def-special-environment (name (&key accessor binder binder*) + &rest vars) + "Define two macros for dealing with groups or related special variables. + +ACCESSOR is defined as a macro: (defmacro ACCESSOR (VARS &rest +BODY)). Each element of VARS will be bound to the +current (dynamic) value of the special variable. + +BINDER is defined as a macro for introducing (and binding new) +special variables. It is basically a readable LET form with the +prorpe declarations appended to the body. The first argument to +BINDER must be a form suitable as the first argument to LET. + +ACCESSOR defaults to a new symbol in the same package as NAME +which is the concatenation of \"WITH-\" NAME. BINDER is built as +\"BIND-\" and BINDER* is BINDER \"*\"." + (unless accessor + (setf accessor (format-symbol (symbol-package name) "~A-~A" '#:with name))) + (unless binder + (setf binder (format-symbol (symbol-package name) "~A-~A" '#:bind name))) + (unless binder* + (setf binder* (format-symbol (symbol-package binder) "~A~A" binder '#:*))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (flet () + (defmacro ,binder (requested-vars &body body) + (check-required ',name ',vars (mapcar #'car requested-vars)) + `(let ,requested-vars + (declare (special ,@(mapcar #'car requested-vars))) + ,@body)) + (defmacro ,binder* (requested-vars &body body) + (check-required ',name ',vars (mapcar #'car requested-vars)) + `(let* ,requested-vars + (declare (special ,@(mapcar #'car requested-vars))) + ,@body)) + (defmacro ,accessor (requested-vars &body body) + (check-required ',name ',vars requested-vars) + `(locally (declare (special ,@requested-vars)) + ,@body)) + ',name))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE -- 1.7.10.4