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

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

dev/config.lisp

@@ -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

dev/lift.lisp

@@ -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)
-|#
+|#

dev/macros.lisp

@@ -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)

dev/measuring.lisp

@@ -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)))))
 

dev/packages.lisp

@@ -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)))))
-
+

dev/reports.lisp

@@ -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

dev/utilities.lisp

@@ -495,4 +495,3 @@ if `putative-pair` is a cons cell with a non-nil cdr."
 	 (format nil "~a" thing))
 	(t
 	 thing)))
-

test/test-dynamic-variables.lisp

@@ -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))))

website/source/index.md

@@ -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.