get rid of defclass-star dependency by expanding a few macros inline and keeping their original in commented out form
Mon Jul 14 08:12:22 PDT 2008 attila.lendvai@gmail.com
* get rid of defclass-star dependency by expanding a few macros inline and keeping their original in commented out form
diff -rN -u old-stefil/duplicates.lisp new-stefil/duplicates.lisp
--- old-stefil/duplicates.lisp 2014-07-29 11:56:42.000000000 -0700
+++ new-stefil/duplicates.lisp 2014-07-29 11:56:42.000000000 -0700
@@ -172,7 +172,7 @@
,(when create-class
`(,defclass-macro-name ,class-name ,direct-superclasses
,(if chain-parents
- (append `((parent-context nil :accessor parent-context-of)) direct-slots) ; accessor is explicitly given to force it to be interned in this package
+ (append `((parent-context :initform nil :accessor parent-context-of)) direct-slots) ; accessor is explicitly given to force it to be interned in this package
direct-slots)))
,(when create-struct
`(defstruct (,name ,@struct-options)
@@ -222,6 +222,7 @@
(defun (setf ,extractor-name) (value)
(setf ,special-var-name value))))))
+#+nil
(defmacro define-dynamic-context* (name direct-slots &rest args
&key (defclass-macro-name 'defclass*)
&allow-other-keys)
diff -rN -u old-stefil/package.lisp new-stefil/package.lisp
--- old-stefil/package.lisp 2014-07-29 11:56:42.000000000 -0700
+++ new-stefil/package.lisp 2014-07-29 11:56:42.000000000 -0700
@@ -9,7 +9,14 @@
(defpackage :stefil
(:shadow #:log)
- (:use :cl :swank :metabang-bind :defclass-star :alexandria :iterate :stefil-system)
+ (:use
+ :common-lisp
+ :swank
+ :metabang-bind
+ :alexandria
+ :iterate
+ :stefil-system
+ )
(:export
#:find-test
diff -rN -u old-stefil/self-tests.lisp new-stefil/self-tests.lisp
--- old-stefil/self-tests.lisp 2014-07-29 11:56:42.000000000 -0700
+++ new-stefil/self-tests.lisp 2014-07-29 11:56:42.000000000 -0700
@@ -7,7 +7,13 @@
(in-package :stefil)
(defpackage :stefil-test
- (:use :common-lisp :metabang-bind :defclass-star :alexandria :iterate :stefil)
+ (:use
+ :common-lisp
+ :metabang-bind
+ :alexandria
+ :iterate
+ :stefil
+ )
(:shadow #:deftest)
(:export #:test))
diff -rN -u old-stefil/stefil.asd new-stefil/stefil.asd
--- old-stefil/stefil.asd 2014-07-29 11:56:42.000000000 -0700
+++ new-stefil/stefil.asd 2014-07-29 11:56:42.000000000 -0700
@@ -34,7 +34,7 @@
"Levente Mészáros <levente.meszaros@gmail.com>")
:licence "BSD / Public domain"
:description "Stefil - Simple Test Framework In Lisp"
- :depends-on (:swank :alexandria :iterate :metabang-bind :defclass-star)
+ :depends-on (:swank :alexandria :iterate :metabang-bind)
:default-component-class local-cl-source-file
:serial t
:components
diff -rN -u old-stefil/stefil.lisp new-stefil/stefil.lisp
--- old-stefil/stefil.lisp 2014-07-29 11:56:42.000000000 -0700
+++ new-stefil/stefil.lisp 2014-07-29 11:56:42.000000000 -0700
@@ -33,21 +33,21 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; conditions
-(defcondition* test-related-condition ()
- ((test nil)))
+(define-condition test-related-condition ()
+ ((test :initform nil :accessor test-of :initarg :test)))
-(defcondition* test-style-warning (style-warning test-related-condition simple-warning)
+(define-condition test-style-warning (style-warning test-related-condition simple-warning)
())
-(defcondition* assertion-failed (test-related-condition error)
- ((failure-description))
+(define-condition assertion-failed (test-related-condition error)
+ ((failure-description :accessor failure-description-of :initarg :failure-description))
(:report (lambda (c stream)
(format stream "Test assertion failed:~%~%")
(describe (failure-description-of c) stream))))
-(defcondition* error-in-teardown (error)
- ((condition)
- (fixture))
+(define-condition error-in-teardown (error)
+ ((condition :accessor condition-of :initarg :condition)
+ (fixture :accessor fixture-of :initarg :fixture))
(:report (lambda (c stream)
(format stream "Error while running teardown of fixture ~A:~%~%~A" (fixture-of c) (condition-of c)))))
@@ -55,12 +55,19 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; some classes
-(defclass* testable ()
+#+nil
+(defclass-star:defclass* testable ()
((name :type symbol)
(parent nil :initarg nil :type (or null testable))
(children (make-hash-table) :documentation "A mapping from testable names to testables")
(auto-call #t :type boolean :documentation "Controls whether to automatically call this test when its parent suite is invoked. Enabled by default.")))
+(defclass testable ()
+ ((name :accessor name-of :initarg :name :type symbol)
+ (parent :initform nil :accessor parent-of :type (or null testable))
+ (children :initform (make-hash-table) :accessor children-of :initarg :children :documentation "A mapping from testable names to testables")
+ (auto-call :initform t :accessor auto-call-p :initarg :auto-call :type boolean :documentation "Controls whether to automatically call this test when its parent suite is invoked. Enabled by default.")))
+
(defprint-object (self testable :identity #f :type #f)
(format t "test ~S" (name-of self))
(bind ((children (count-tests self)))
@@ -100,7 +107,7 @@
(iter (for (nil child) :in-hashtable (children-of self))
(summing (count-tests child))))))
-(defclass* test (testable)
+#+nil(defclass-star:defclass* test (testable)
((package nil)
(lambda-list nil)
(compile-before-run #t :type boolean)
@@ -108,23 +115,42 @@
(documentation nil)
(body nil)))
+(defclass test (testable)
+ ((package :initform nil :accessor package-of :initarg :package)
+ (lambda-list :initform nil :accessor lambda-list-of :initarg :lambda-list)
+ (compile-before-run :initform t :accessor compile-before-run-p :initarg :compile-before-run :type boolean)
+ (declarations :initform nil :accessor declarations-of :initarg :declarations)
+ (documentation :initform nil :accessor documentation-of :initarg :documentation)
+ (body :initform nil :accessor body-of :initarg :body)))
+
(defun make-test (name &rest args &key &allow-other-keys)
(apply #'make-instance 'test :name name args))
(defun make-suite (name &rest args &key &allow-other-keys)
(apply #'make-instance 'test :name name args))
-
-(defclass* failure-description ()
+#+nil
+(defclass-star:defclass* failure-description ()
((test-context-backtrace)
(progress-char #\X :allocation :class)
(expected *failures-and-errors-are-expected* :type boolean)))
-(defclass* failed-assertion (failure-description)
+(defclass failure-description ()
+ ((test-context-backtrace :accessor test-context-backtrace-of :initarg :test-context-backtrace)
+ (progress-char :initform #\X :accessor progress-char-of :initarg :progress-char :allocation :class)
+ (expected :initform *failures-and-errors-are-expected* :accessor expected-p :initarg :expected :type boolean)))
+
+#+nil
+(defclass-star:defclass* failed-assertion (failure-description)
((form)
(format-control)
(format-arguments)))
+(defclass failed-assertion (failure-description)
+ ((form :accessor form-of :initarg :form)
+ (format-control :accessor format-control-of :initarg :format-control)
+ (format-arguments :accessor format-arguments-of :initarg :format-arguments)))
+
(defmethod describe-object ((self failed-assertion) stream)
(let ((*print-circle* nil))
(apply #'format stream (format-control-of self) (format-arguments-of self))))
@@ -135,18 +161,28 @@
(mapcar (compose #'name-of #'test-of)
(test-context-backtrace-of self))))
-(defclass* missing-condition (failure-description)
+#+nil
+(defclass-star:defclass* missing-condition (failure-description)
((form)
(condition)))
+(defclass missing-condition (failure-description)
+ ((form :accessor form-of :initarg :form)
+ (condition :accessor condition-of :initarg :condition)))
+
(defmethod describe-object ((self missing-condition) stream)
(let ((*print-circle* nil))
(format stream "~S failed to signal condition ~S" (form-of self) (condition-of self))))
-(defclass* unexpected-error (failure-description)
+#+nil
+(defclass-star:defclass* unexpected-error (failure-description)
((condition)
(progress-char #\E :allocation :class)))
+(defclass unexpected-error (failure-description)
+ ((condition :accessor condition-of :initarg :condition)
+ (progress-char :initform #\E :accessor progress-char-of :initarg :progress-char :allocation :class)))
+
(defprint-object (self unexpected-error :identity #f :type #f)
(format t "error ~{~A~^,~}: ~S"
(mapcar (compose #'name-of #'test-of)
@@ -202,6 +238,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; the real thing
+#+nil
(define-dynamic-context* global-context
((failure-descriptions (make-array 8 :adjustable #t :fill-pointer 0))
(assertion-count 0)
@@ -215,6 +252,19 @@
(run-fixtures (make-hash-table))
(test-lambdas (make-hash-table) :documentation "test -> compiled test lambda mapping for this test run")))
+(define-dynamic-context global-context
+ ((failure-descriptions :initform (make-array 8 :adjustable t :fill-pointer 0) :accessor failure-descriptions-of :initarg :failure-descriptions)
+ (assertion-count :initform 0 :accessor assertion-count-of :initarg :assertion-count)
+ (progress-char-count :initform 0 :accessor progress-char-count-of :initarg :progress-char-count)
+ (print-test-run-progress-p :initform *print-test-run-progress* :accessor print-test-run-progress-p :initarg :print-test-run-progress-p :type boolean)
+ (debug-on-unexpected-error-p :initform *debug-on-unexpected-error* :accessor debug-on-unexpected-error-p :initarg :debug-on-unexpected-error-p :type boolean)
+ (debug-on-assertion-failure-p :initform *debug-on-assertion-failure* :accessor debug-on-assertion-failure-p :initarg :debug-on-assertion-failure-p :type boolean)
+ (toplevel-context :initform nil :accessor toplevel-context-of :initarg :toplevel-context)
+ (current-test :initform nil :accessor current-test-of :initarg :current-test)
+ (run-tests :initform (make-hash-table) :accessor run-tests-of :initarg :run-tests :documentation "test -> context mapping")
+ (run-fixtures :initform (make-hash-table) :accessor run-fixtures-of :initarg :run-fixtures)
+ (test-lambdas :initform (make-hash-table) :accessor test-lambdas-of :initarg :test-lambdas :documentation "test -> compiled test lambda mapping for this test run")))
+
(defprint-object (self global-context :identity #f :type #f)
(format t "test-run: ~A tests, ~A assertions, ~A failures (~A expected) in ~A sec"
(hash-table-count (run-tests-of self)) (assertion-count-of self)
@@ -277,6 +327,7 @@
(setf (gethash test (test-lambdas-of context)) test-lambda))
test-lambda)))
+#+nil
(define-dynamic-context* context
((test)
(internal-realtime-spent-with-test nil)
@@ -284,6 +335,13 @@
(number-of-added-failure-descriptions 0))
:chain-parents #t)
+(define-dynamic-context context
+ ((test :accessor test-of :initarg :test)
+ (internal-realtime-spent-with-test :initform nil :accessor internal-realtime-spent-with-test-of :initarg :internal-realtime-spent-with-test)
+ (test-arguments :accessor test-arguments-of :initarg :test-arguments)
+ (number-of-added-failure-descriptions :initform 0 :accessor number-of-added-failure-descriptions-of :initarg :number-of-added-failure-descriptions))
+ :chain-parents #t)
+
(defprint-object (self context :identity #f :type #f)
(format t "test-run ~@<(~S~{~^ ~S~})~@:>"
(name-of (test-of self))
Warning: CRC errors found. These are probably harmless but should be repaired.
See 'darcs gzcrcs --help' for more information.