Permalink
Browse files

various minor LIFT changes

tweak logging so that entries are slightly more useful

add while-counting-repetitions* and while-counting-events* which
don't use with-timeout

tweak report generation to add hook so that we can modify the
display name easily

update website templates slightly.

Fix bug wherein inherited dynamic-variables were
overriding more specific ones and add tests for same.

Internal lift tests added; no AG tests
Testsuite run (note that passing AG tests requires an update
to lisp/tests/twinql/lift-twinql-integeration since that file
had a bug masked by the LIFT dynamic-variables bug)
Performance implications: none
Release notes: none (all internal changes)

Change-Id: I66638826c20170a55553e8e6314f7779fa79c6c79
  • Loading branch information...
1 parent 9bc742d commit 907e17812afdee75caba63c9f8f39d7edc0c27c8 Gary King committed with dklayer Apr 26, 2010
Showing with 243 additions and 66 deletions.
  1. +7 −6 COPYING
  2. +2 −0 dev/config.lisp
  3. +23 −25 dev/lift.lisp
  4. +71 −1 dev/macros.lisp
  5. +19 −1 dev/measuring.lisp
  6. +5 −1 dev/packages.lisp
  7. +1 −1 dev/reports.lisp
  8. +0 −1 dev/utilities.lisp
  9. +65 −0 test/test-dynamic-variables.lisp
  10. +8 −7 website/source/index.md
  11. +42 −23 website/website.tmproj
View
13 COPYING
@@ -1,4 +1,4 @@
-Copyright (c) 2002-2008 Gary Warren King (gwking@metabang.com)
+Copyright (c) 2002-2010 Gary Warren King (gwking@metabang.com)
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
@@ -54,11 +54,12 @@ Experimental Knowledge Systems Laboratory
Professor Paul Cohen, Director.
All rights reserved.
-Permission to use, copy, modify and distribute this software and its
-documentation is hereby granted without fee for non-commercial uses
-only (not for resale), provided that the above copyright notice of EKSL,
-this paragraph and the one following appear in all copies and in
-supporting documentation.
+Permission is hereby granted, free of charge, to any person obtaining a
+copy of this software and associated documentation files (the "Software"),
+to deal in the Software without restriction, including without limitation
+the rights to use, copy, modify, merge, publish, distribute, sublicense,
+and/or sell copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following conditions:
EKSL makes no representation about the suitability of this software for any
purposes. It is provided "AS IS", without express or implied warranties
View
@@ -385,6 +385,8 @@ use asdf:test-op or bind *current-asdf-system-name* yourself."))))))
(writable-directory-p dest))
(format *debug-io* "~&Sending report (format ~s) to ~a"
format dest)
+ (loop for hook in (report-hooks-for :report-display-name) do
+ (funcall hook format dest))
(test-result-report
*test-result* dest format))
(t
View
@@ -631,26 +631,26 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
;;?? we assume that we won't have too deep a hierarchy or too many
;; dv's or functions so that having lots of duplicate names is OK
(let ((slots nil)
- (dynamic-variables nil)
+ (inherited-dynamic-variables nil)
+ (dynamic-variables (%build-pairs (def :direct-dynamic-variables)))
(function-specs nil))
(dolist (super (def :superclasses))
(cond ((find-testsuite super)
(setf slots (append slots (test-slots super))
- dynamic-variables
- (append dynamic-variables
+ inherited-dynamic-variables
+ (append inherited-dynamic-variables
(testsuite-dynamic-variables super))
function-specs
(append function-specs
(testsuite-function-specs super))))
(t
(error 'testsuite-not-defined :testsuite-name super))))
+ (loop for pair in inherited-dynamic-variables
+ unless (find (first pair) dynamic-variables :key #'first) collect
+ (progn (push pair dynamic-variables) pair))
(setf (def :slot-names)
(remove-duplicates (append (def :direct-slot-names) slots))
- (def :dynamic-variables)
- (remove-duplicates
- (append (%build-pairs (def :direct-dynamic-variables))
- dynamic-variables)
- :key #'car)
+ (def :dynamic-variables) (nreverse dynamic-variables)
(def :function-specs)
(remove-duplicates
(append (def :function-specs) function-specs)))
@@ -1493,28 +1493,26 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(make-instance 'test-timeout-condition
:maximum-time (maximum-time testsuite)))))))
-(defmethod testsuite-log-data ((suite t) )
+(defmethod testsuite-log-data ((suite t))
nil)
+(defmethod testsuite-log-data :around ((suite t))
+ (multiple-value-bind (additional error?)
+ (ignore-errors (call-next-method))
+ (if error?
+ `(:error "error occured gathering additional data")
+ additional)))
+
(defmethod test-case-teardown :around ((suite log-results-mixin) result)
(declare (ignore result))
(let ((problem (getf (test-data suite) :problem)))
(unless (and problem (typep problem 'test-error-mixin))
- (multiple-value-bind (additional error?)
- (ignore-errors (testsuite-log-data suite))
- (generate-log-entry
- nil
- (getf (test-data suite) :seconds)
- (getf (test-data suite) :conses)
- :additional-data
- `(:suite ,(form-keyword *current-testsuite-name*)
- :name ,(form-keyword *current-test-case-name*)
- ,@(when (and *test-result*
- (result-uuid *test-result*))
- `(:uuid ,(result-uuid *test-result*)))
- ,@(if error?
- `(:error "error occured gathering additional data")
- additional)))))))
+ (generate-log-entry
+ nil
+ (getf (test-data suite) :seconds)
+ (getf (test-data suite) :conses)
+ :additional-data
+ `(,@(testsuite-log-data suite))))))
;;?? might be "cleaner" with a macrolet (cf. lift-result)
(defun lift-property (name)
@@ -1573,4 +1571,4 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(test-case-option 'test-dependencies-helper 'test-c :depends-on)
(setf (test-case-option 'test-dependencies-helper 'test-c :depends-on) :test-c)
(remove-test-case-options 'test-dependencies-helper)
-|#
+|#
View
@@ -157,6 +157,41 @@ be executed more than a fixnum number of times. The `delay` defaults to
,gevent-count))))))))
(funcall ,gfn))))
+(defmacro while-counting-repetitions* ((&optional (delay 1.0)) &body body)
+ "Count the number of times `body` executes in `delay` seconds.
+
+Warning: assumes that `body` will not be executed more than a fixnum
+number of times. The `delay` defaults to 1.0.
+
+Unlike [while-counting-repetitions][] , this does not use with-timeout and
+therefore assumes that `body` executes quickly relative to delay."
+ (let ((gevent-count (gensym "count-"))
+ (gdelay (gensym "delay-"))
+ (gduration (gensym "duration-"))
+ (gfn (gensym "fn-"))
+ (gstart (gensym "start-"))
+ (gend (gensym "end-")))
+ `(let ((,gfn
+ (compile
+ nil
+ '(lambda ()
+ (let* ((,gevent-count 0)
+ (,gdelay (truncate (* ,delay internal-time-units-per-second)))
+ (,gstart (get-internal-real-time))
+ (,gend (+ ,gstart ,gdelay)))
+ (declare (type fixnum ,gevent-count))
+ (loop while (< (get-internal-real-time) ,gend) do
+ (progn ,@body)
+ (setf ,gevent-count (the fixnum (1+ ,gevent-count))))
+ (let ((,gduration (/ (- ,gend ,gstart)
+ internal-time-units-per-second)))
+ (values
+ (if (plusp ,gevent-count)
+ (float (/ ,gevent-count ,gduration))
+ 0)
+ ,gduration ,gevent-count)))))))
+ (funcall ,gfn))))
+
(defmacro while-counting-events ((&optional (delay 1.0)) &body body)
"Returns the count of the number of times `did-event` was called during
`delay` seconds. See also: [while-counting-repetitions][]."
@@ -172,7 +207,42 @@ be executed more than a fixnum number of times. The `delay` defaults to
(progn ,@body)))
(timeout-error (c)
(declare (ignore c))
- (float (/ ,gevent-count ,delay))))))))
+ (float (/ ,gevent-count ,delay))))))))
+
+(defmacro while-counting-events* ((&optional (delay 1.0)) &body body)
+ "Count the number of times `did-event` is called `body` during `delay`.
+
+Warning: assumes that `body` will not be executed more than a fixnum
+number of times. The `delay` defaults to 1.0.
+
+Unlike [while-counting-events][] , this does not use with-timeout and
+therefore assumes that `body` executes quickly relative to delay."
+ (let ((gevent-count (gensym "count-"))
+ (gdelay (gensym "delay-"))
+ (gduration (gensym "duration-"))
+ (gfn (gensym "fn-"))
+ (gstart (gensym "start-"))
+ (gend (gensym "end-")))
+ `(let* ((,gfn (lambda ()
+ (let* ((,gevent-count 0)
+ (,gdelay (truncate (* ,delay internal-time-units-per-second)))
+ (,gstart (get-internal-real-time))
+ (,gend (+ ,gstart ,gdelay)))
+ (declare (type fixnum ,gevent-count))
+ (flet ((did-event () (incf ,gevent-count)))
+ (loop while (< (get-internal-real-time) ,gend) do
+ (progn ,@body)))
+ (let ((,gduration (float (/ (- ,gend ,gstart)
+ internal-time-units-per-second))))
+ (values
+ (if (plusp ,gevent-count)
+ (/ ,gevent-count ,gduration)
+ 0)
+ ,gduration ,gevent-count))))))
+ #+(or)
+ (unless (compiled-function-p ,gfn)
+ (setf ,gfn (compile nil ,gfn)))
+ (funcall ,gfn))))
;; stolen from metatilities
(defmacro muffle-redefinition-warnings (&body body)
View
@@ -96,6 +96,23 @@ The accuracy can be no greater than {hs internal-time-units-per-second}.")
(t
(funcall fn)))))
+(defun standard-log-data ()
+ (let ((custom
+ (loop for hook in (report-hooks-for :standard-log-data) append
+ (multiple-value-bind (datum error?)
+ (funcall hook)
+ (if error? `(:error ,(format nil "calling hook ~a" hook)) datum)))))
+ `(,@(when *current-testsuite-name*
+ `(:suite ,(form-keyword *current-testsuite-name*)))
+ ,@(when *current-test-case-name*
+ `(:name ,(form-keyword *current-test-case-name*)))
+ ,@(when (and *test-result* (testsuite-initargs *test-result*))
+ `(:testsuite-initargs ,(testsuite-initargs *test-result*)))
+ ,@(when (and *test-result*
+ (result-uuid *test-result*))
+ `(:uuid ,(result-uuid *test-result*)))
+ ,@(when custom custom))))
+
(defun generate-profile-log-entry (log-name name seconds conses results error)
(generate-log-entry name seconds conses :results results :error error
:sample-count (and (plusp (current-profile-sample-count))
@@ -119,7 +136,8 @@ The accuracy can be no greater than {hs internal-time-units-per-second}.")
(date-stamp :include-time? t :time-delimiter #\:)
(or name *log-tag*)
(hostname) *current-user* (lisp-version-string)
- seconds conses additional-data
+ seconds conses
+ (append (standard-log-data) additional-data)
results sample-count
error)))))
View
@@ -24,13 +24,17 @@
#:*log-header-hooks*
#:*log-footer-hooks*
#:report-hooks-for
+ #:add-report-hook-for
#:with-profile-report
#:describe-test-result
#:make-test-result
#:count-repetitions
#:while-counting-repetitions
#:while-counting-events
+ #:while-counting-repetitions*
+ #:while-counting-events*
#:with-timeout
+ #:did-event
#:testsuite-ambiguous
#:testsuite-not-defined)
@@ -184,4 +188,4 @@ doesn't seem to include. LIFT will define these for now but you may want to cons
:type (or type (pathname-type pathname))
:directory directory)
(asdf::system-source-directory system)))))
-
+
View
@@ -934,8 +934,8 @@ lift::(progn
(setf seconds (first measures) conses (second measures)
results result error errorp))
;; cleanup / ensure we get report
- (generate-profile-log-entry log-name name seconds conses results error)
(when (and style (> (current-profile-sample-count) 0))
+ (generate-profile-log-entry log-name name seconds conses results error)
(let ((pathname (if destination-supplied?
destination
(unique-filename
View
@@ -495,4 +495,3 @@ if `putative-pair` is a cons cell with a non-nil cdr."
(format nil "~a" thing))
(t
thing)))
-
@@ -60,4 +60,69 @@ marked as special in the global environment.")
(ensure-null (lift::errors r))
(ensure-null (lift::failures r))))
+;;;;
+
+(deftestsuite test-dynamic-variables-helper-parent ()
+ ()
+ (:dynamic-variables
+ (*tdvhp* 1)))
+
+(addtest (test-dynamic-variables-helper-parent)
+ test-1
+ (ensure-same *tdvhp* 1))
+
+(deftestsuite test-dynamic-variables-helper-other-parent ()
+ ()
+ (:dynamic-variables
+ (*tdvhp* 3)))
+
+(deftestsuite test-dynamic-variables-helper-child (test-dynamic-variables-helper-parent)
+ ()
+ (:dynamic-variables
+ (*tdvhp* 2)))
+
+(addtest (test-dynamic-variables-helper-child)
+ test-1
+ (ensure-same *tdvhp* 2))
+
+(deftestsuite test-dynamic-variables-helper-two-parents-a
+ (test-dynamic-variables-helper-parent test-dynamic-variables-helper-other-parent)
+ ())
+
+(addtest (test-dynamic-variables-helper-two-parents-a)
+ test-1
+ (ensure-same *tdvhp* 1))
+
+(deftestsuite test-dynamic-variables-helper-two-parents-b
+ (test-dynamic-variables-helper-other-parent test-dynamic-variables-helper-parent)
+ ())
+
+(addtest (test-dynamic-variables-helper-two-parents-b)
+ test-1
+ (ensure-same *tdvhp* 3))
+;;;
+
+(deftestsuite test-dynamic-variables-inheritance (test-dynamic-variables)
+ ())
+
+(addtest (test-dynamic-variables-inheritance)
+ test-1
+ (let ((r (run-tests :suite 'test-dynamic-variables-helper-child)))
+ (ensure-same (length (tests-run r)) 1)
+ (ensure-null (lift::errors r))
+ (ensure-null (lift::failures r))))
+
+(addtest (test-dynamic-variables-inheritance)
+ test-two-parents-1
+ (let ((r (run-tests :suite 'test-dynamic-variables-helper-two-parents-a)))
+ (ensure-same (length (tests-run r)) 1)
+ (ensure-null (lift::errors r))
+ (ensure-null (lift::failures r))))
+
+(addtest (test-dynamic-variables-inheritance)
+ test-two-parents-2
+ (let ((r (run-tests :suite 'test-dynamic-variables-helper-two-parents-b)))
+ (ensure-same (length (tests-run r)) 1)
+ (ensure-null (lift::errors r))
+ (ensure-null (lift::failures r))))
View
@@ -5,9 +5,9 @@
* [Mailing Lists][3]
* [Getting it][4]
- * [Documentation][5]
+{remark * [Documentation][5] }
* [News][6]
- * [Test results][tr]
+{remark * [Test results][tr] }
* [Changelog][7]
[3]: #mailing-lists
@@ -65,12 +65,11 @@ The externals of LIFT haven't changed too much though the implementation has bee
### Where is it
-A [Darcs][16] repository is available. The commands are
-listed below:
+metabang.com is slowly switching from [darcs][] to [git][]
+for source control; the current LIFT repository is on
+[github][github-lift] and you can clone it using:
- [16]: http://www.darcs.net/
-
- darcs get http://common-lisp.net/project/lift/
+ git clone git://github.com/gwkkwg/lift
LIFT is also [ASDF installable][18]. Its CLiki home is right
[where][19] you'd expect.
@@ -86,6 +85,8 @@ There's also a handy [gzipped tar file][20].
### What is happening
+10 April 2010 - moved to git; lots of other stuff too but it's all undocumented :-(.
+
1 March 2008
Much excitement and new features. If only someone would write up the documentation.
Oops, something went wrong.

0 comments on commit 907e178

Please sign in to comment.