From 13527b5ced0a6d4ac3bad84e176cbb42a032ed2c Mon Sep 17 00:00:00 2001 From: AJ Rossini Date: Sun, 30 Sep 2007 14:46:18 +0200 Subject: [PATCH] using darcs repo of lift --- external/{lift => lift.darcs}/COPYING | 0 external/{lift => lift.darcs}/RELNOTES | 0 .../{lift => lift.darcs}/compare/fiveam-tests.lisp | 0 .../{lift => lift.darcs}/compare/lift-tests.lisp | 0 external/{lift => lift.darcs}/compare/notes.text | 0 .../{lift => lift.darcs}/compare/rt-tests.lisp | 0 .../{lift => lift.darcs}/compare/xlunit-tests.lisp | 0 external/{lift => lift.darcs}/data/beale.list | 0 external/{lift => lift.darcs}/data/shortwords.text | 0 external/{lift => lift.darcs}/data/wordlist-2.text | 0 external/{lift => lift.darcs}/data/wordlist.text | 0 external/{lift => lift.darcs}/dev/changes.lisp | 0 external/lift.darcs/dev/config.lisp | 175 +++++++++++ external/{lift => lift.darcs}/dev/copy-file.lisp | 0 .../{lift => lift.darcs}/dev/lift-interface.lisp | 0 external/{lift => lift.darcs}/dev/lift-notes.lisp | 0 .../{lift => lift.darcs}/dev/lift-randomized.lisp | 0 external/{lift => lift.darcs}/dev/lift.lisp | 327 +++++++++------------ external/{lift => lift.darcs}/dev/measuring.lisp | 100 ++++++- external/{lift => lift.darcs}/dev/notes.text | 0 external/lift.darcs/dev/packages.lisp | 52 ++++ external/{lift => lift.darcs}/dev/port.lisp | 29 +- external/{lift => lift.darcs}/dev/prototypes.lisp | 0 .../{lift => lift.darcs}/dev/random-testing.lisp | 0 external/{lift => lift.darcs}/dev/reports.lisp | 100 ++++--- .../examples/basic-examples.lisp | 0 .../examples/random-testing.lisp | 0 external/lift.darcs/lift-standard.config | 39 +++ external/{lift => lift.darcs}/lift-test.asd | 0 external/{lift => lift.darcs}/lift.asd | 12 +- .../resources/test-style.css} | 0 .../{lift => lift.darcs}/test/equality-tests.lisp | 2 +- .../{lift => lift.darcs}/test/finding-tests.lisp | 0 external/{lift => lift.darcs}/test/lift-test.lisp | 78 ++++- .../test/test-dynamic-variables.lisp | 0 .../{lift => lift.darcs}/test/test-prototypes.lisp | 0 .../{lift => lift.darcs}/test/test-timeout.lisp | 0 .../test/tests-in-progress.lisp | 15 - .../source/assets/ILC-2003-Presentation.pdf | Bin .../source/assets/ILC-2003-Presentation.swf | Bin .../website/source/assets/test-framework.pdf | Bin .../{lift => lift.darcs}/website/source/faq.md | 0 external/lift.darcs/website/source/footer.md | 13 + .../website/source/glossary.md | 0 .../{lift => lift.darcs}/website/source/header.md | 12 +- .../website/source/navigation.md | 0 .../website/source/overview.md | 0 .../{lift => lift.darcs}/website/source/style.css | 0 .../website/source/user-guide.css | 0 .../website/source/user-guide.md | 0 .../ILC-2003-Presentation.key/.typeAttributes.dict | 0 .../ILC-2003-Presentation.key/Contents/PkgInfo | 0 .../stuff/ILC-2003-Presentation.key/Denim.tiff | Bin .../stuff/ILC-2003-Presentation.key/diagram-1.png | Bin .../stuff/ILC-2003-Presentation.key/diagram.png | Bin .../stuff/ILC-2003-Presentation.key/eksl-lm.png | Bin .../stuff/ILC-2003-Presentation.key/index.apxl.gz | Bin .../ILC-2003-Presentation.key/thumbs/mt0-0.tiff | Bin .../ILC-2003-Presentation.key/thumbs/mt0-1.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st0.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st1.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st10.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st11.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st12.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st13.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st14.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st15.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st16.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st17.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st18.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st19.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st2.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st20.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st21.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st22.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st23.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st24.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st25.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st26.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st27.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st28.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st29.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st3.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st30.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st31.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st4.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st5.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st6.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st7.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st8.tiff | Bin .../ILC-2003-Presentation.key/thumbs/st9.tiff | Bin .../stuff/ILC-2003-Presentation.key/warnings-1.png | Bin .../{lift => lift.darcs}/website/stuff/Temp.lisp | 0 external/lift/dev/config.lisp | 159 ---------- external/lift/dev/macros.lisp | 82 ------ external/lift/dev/packages.lisp | 19 -- external/lift/website/source/footer.md | 10 - 97 files changed, 691 insertions(+), 533 deletions(-) rename external/{lift => lift.darcs}/COPYING (100%) rename external/{lift => lift.darcs}/RELNOTES (100%) rename external/{lift => lift.darcs}/compare/fiveam-tests.lisp (100%) rename external/{lift => lift.darcs}/compare/lift-tests.lisp (100%) rename external/{lift => lift.darcs}/compare/notes.text (100%) rename external/{lift => lift.darcs}/compare/rt-tests.lisp (100%) rename external/{lift => lift.darcs}/compare/xlunit-tests.lisp (100%) rename external/{lift => lift.darcs}/data/beale.list (100%) rename external/{lift => lift.darcs}/data/shortwords.text (100%) rename external/{lift => lift.darcs}/data/wordlist-2.text (100%) rename external/{lift => lift.darcs}/data/wordlist.text (100%) rename external/{lift => lift.darcs}/dev/changes.lisp (100%) create mode 100644 external/lift.darcs/dev/config.lisp rename external/{lift => lift.darcs}/dev/copy-file.lisp (100%) rename external/{lift => lift.darcs}/dev/lift-interface.lisp (100%) rename external/{lift => lift.darcs}/dev/lift-notes.lisp (100%) rename external/{lift => lift.darcs}/dev/lift-randomized.lisp (100%) rename external/{lift => lift.darcs}/dev/lift.lisp (91%) rename external/{lift => lift.darcs}/dev/measuring.lisp (67%) rename external/{lift => lift.darcs}/dev/notes.text (100%) create mode 100644 external/lift.darcs/dev/packages.lisp rename external/{lift => lift.darcs}/dev/port.lisp (87%) rename external/{lift => lift.darcs}/dev/prototypes.lisp (100%) rename external/{lift => lift.darcs}/dev/random-testing.lisp (100%) rename external/{lift => lift.darcs}/dev/reports.lisp (88%) rename external/{lift => lift.darcs}/examples/basic-examples.lisp (100%) rename external/{lift => lift.darcs}/examples/random-testing.lisp (100%) create mode 100644 external/lift.darcs/lift-standard.config rename external/{lift => lift.darcs}/lift-test.asd (100%) rename external/{lift => lift.darcs}/lift.asd (86%) rename external/{lift/resources/style.css => lift.darcs/resources/test-style.css} (100%) rename external/{lift => lift.darcs}/test/equality-tests.lisp (97%) rename external/{lift => lift.darcs}/test/finding-tests.lisp (100%) rename external/{lift => lift.darcs}/test/lift-test.lisp (85%) rename external/{lift => lift.darcs}/test/test-dynamic-variables.lisp (100%) rename external/{lift => lift.darcs}/test/test-prototypes.lisp (100%) rename external/{lift => lift.darcs}/test/test-timeout.lisp (100%) rename external/{lift => lift.darcs}/test/tests-in-progress.lisp (92%) rename external/{lift => lift.darcs}/website/source/assets/ILC-2003-Presentation.pdf (100%) rename external/{lift => lift.darcs}/website/source/assets/ILC-2003-Presentation.swf (100%) rename external/{lift => lift.darcs}/website/source/assets/test-framework.pdf (100%) rename external/{lift => lift.darcs}/website/source/faq.md (100%) create mode 100644 external/lift.darcs/website/source/footer.md rename external/{lift => lift.darcs}/website/source/glossary.md (100%) rename external/{lift => lift.darcs}/website/source/header.md (69%) rename external/{lift => lift.darcs}/website/source/navigation.md (100%) rename external/{lift => lift.darcs}/website/source/overview.md (100%) rename external/{lift => lift.darcs}/website/source/style.css (100%) rename external/{lift => lift.darcs}/website/source/user-guide.css (100%) rename external/{lift => lift.darcs}/website/source/user-guide.md (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/.typeAttributes.dict (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/Contents/PkgInfo (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/Denim.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/diagram-1.png (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/diagram.png (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/eksl-lm.png (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/index.apxl.gz (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/mt0-0.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/mt0-1.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st0.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st1.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st10.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st11.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st12.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st13.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st14.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st15.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st16.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st17.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st18.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st19.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st2.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st20.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st21.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st22.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st23.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st24.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st25.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st26.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st27.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st28.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st29.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st3.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st30.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st31.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st4.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st5.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st6.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st7.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st8.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/thumbs/st9.tiff (100%) rename external/{lift => lift.darcs}/website/stuff/ILC-2003-Presentation.key/warnings-1.png (100%) rename external/{lift => lift.darcs}/website/stuff/Temp.lisp (100%) delete mode 100644 external/lift/dev/config.lisp delete mode 100644 external/lift/dev/macros.lisp delete mode 100644 external/lift/dev/packages.lisp delete mode 100644 external/lift/website/source/footer.md diff --git a/external/lift/COPYING b/external/lift.darcs/COPYING similarity index 100% rename from external/lift/COPYING rename to external/lift.darcs/COPYING diff --git a/external/lift/RELNOTES b/external/lift.darcs/RELNOTES similarity index 100% rename from external/lift/RELNOTES rename to external/lift.darcs/RELNOTES diff --git a/external/lift/compare/fiveam-tests.lisp b/external/lift.darcs/compare/fiveam-tests.lisp similarity index 100% rename from external/lift/compare/fiveam-tests.lisp rename to external/lift.darcs/compare/fiveam-tests.lisp diff --git a/external/lift/compare/lift-tests.lisp b/external/lift.darcs/compare/lift-tests.lisp similarity index 100% rename from external/lift/compare/lift-tests.lisp rename to external/lift.darcs/compare/lift-tests.lisp diff --git a/external/lift/compare/notes.text b/external/lift.darcs/compare/notes.text similarity index 100% rename from external/lift/compare/notes.text rename to external/lift.darcs/compare/notes.text diff --git a/external/lift/compare/rt-tests.lisp b/external/lift.darcs/compare/rt-tests.lisp similarity index 100% rename from external/lift/compare/rt-tests.lisp rename to external/lift.darcs/compare/rt-tests.lisp diff --git a/external/lift/compare/xlunit-tests.lisp b/external/lift.darcs/compare/xlunit-tests.lisp similarity index 100% rename from external/lift/compare/xlunit-tests.lisp rename to external/lift.darcs/compare/xlunit-tests.lisp diff --git a/external/lift/data/beale.list b/external/lift.darcs/data/beale.list similarity index 100% rename from external/lift/data/beale.list rename to external/lift.darcs/data/beale.list diff --git a/external/lift/data/shortwords.text b/external/lift.darcs/data/shortwords.text similarity index 100% rename from external/lift/data/shortwords.text rename to external/lift.darcs/data/shortwords.text diff --git a/external/lift/data/wordlist-2.text b/external/lift.darcs/data/wordlist-2.text similarity index 100% rename from external/lift/data/wordlist-2.text rename to external/lift.darcs/data/wordlist-2.text diff --git a/external/lift/data/wordlist.text b/external/lift.darcs/data/wordlist.text similarity index 100% rename from external/lift/data/wordlist.text rename to external/lift.darcs/data/wordlist.text diff --git a/external/lift/dev/changes.lisp b/external/lift.darcs/dev/changes.lisp similarity index 100% rename from external/lift/dev/changes.lisp rename to external/lift.darcs/dev/changes.lisp diff --git a/external/lift.darcs/dev/config.lisp b/external/lift.darcs/dev/config.lisp new file mode 100644 index 0000000..a72f444 --- /dev/null +++ b/external/lift.darcs/dev/config.lisp @@ -0,0 +1,175 @@ +(in-package #:lift) + +(defvar *current-configuration-stream* nil) + +(defvar *current-asdf-system-name* nil) + +(eval-when (:load-toplevel :execute) + (when (find-package :asdf) + (defmethod asdf:perform :around ((operation asdf:test-op) (c asdf:system)) + (let ((*current-asdf-system-name* (asdf:component-name c))) + (call-next-method))))) + +(defun find-generic-test-configuration () + (let ((srp (and *current-asdf-system-name* + (find-package :asdf) + (intern (symbol-name 'system-relative-pathname) :asdf)))) + (cond (srp + (or (probe-file (funcall srp + *current-asdf-system-name* + "lift-local.config")) + (probe-file (funcall srp + *current-asdf-system-name* + "lift-standard.config")) + (error "Unable to find lift-local.config or lift-standard.config relative to the current system (~s)" *current-asdf-system-name*))) + (t + (error "Unable to use :generic configuration option either because ASDF is not loaded or because asdf:system-relative-pathname is not bound (maybe try updating?) or because the current system cannot be determined."))))) + +(defun run-tests-from-file (path) + (let ((real-path (cond ((eq path :generic) + (setf path (find-generic-test-configuration))) + (t + (probe-file path))))) + (unless real-path + (error "Unable to find configuration file ~s" path)) + (setf *test-result* + (let* ((*package* *package*) + (*read-eval* nil) + (result (make-test-result path :multiple)) + (*lift-dribble-pathname* nil) + (*lift-debug-output* *debug-io*) + (*lift-standard-output* *standard-output*) + (*test-break-on-errors?* nil) + (*test-do-children?* t) + (*lift-equality-test* 'equal) + (*test-print-length* :follow-print) + (*test-print-level* :follow-print) + (*lift-if-dribble-exists* :append) + (*test-result* result)) + (%run-tests-from-file path))))) + +(defun %run-tests-from-file (path) + (with-open-file (*current-configuration-stream* path + :direction :input + :if-does-not-exist :error) + (let ((form nil)) + (loop while (not (eq (setf form (read *current-configuration-stream* + nil :eof nil)) :eof)) + collect + (handler-bind + ((error (lambda (c) (format + *error-output* + "Error while running ~a from ~a: ~a" + form path c) + (invoke-debugger c)))) + (destructuring-bind + (name &rest args) + form + (assert (typep name 'symbol) nil + "Each command must be a symbol and ~s is not." name) + (setf args (massage-arguments args)) + (cond + ;; check for preferences first (i.e., keywords) + ((eq (symbol-package name) + (symbol-package :keyword)) + ;; must be a preference + (handle-config-preference name args)) + ((subtypep (find-testsuite name) + 'lift:test-mixin) + (apply #'run-tests :suite name + :result *test-result* args)) + (t + (error "Don't understand '~s' while reading from ~s" + form path)))))))) + (values *test-result*)) + +(defun massage-arguments (args) + (loop for arg in args collect + (cond ((and (symbolp arg) + (string= (symbol-name arg) (symbol-name '*standard-output*))) + *standard-output*) + (t arg)))) + +(defmethod handle-config-preference ((name t) args) + (error "Unknown preference ~s (with arguments ~s)" + name args)) + +(defmethod handle-config-preference ((name (eql :include)) args) + (%run-tests-from-file (merge-pathnames (first args) + *current-configuration-stream*))) + +(defmethod handle-config-preference ((name (eql :dribble)) args) + (setf *lift-dribble-pathname* (first args))) + +(defmethod handle-config-preference ((name (eql :debug-output)) args) + (setf *lift-debug-output* (first args))) + +(defmethod handle-config-preference ((name (eql :standard-output)) args) + (setf *lift-standard-output* (first args))) + +(defmethod handle-config-preference ((name (eql :break-on-errors?)) args) + (setf *test-break-on-errors?* (first args))) + +(defmethod handle-config-preference ((name (eql :do-children?)) args) + (setf *test-do-children?* (first args))) + +(defmethod handle-config-preference ((name (eql :equality-test)) args) + (setf *lift-equality-test* (first args))) + +(defmethod handle-config-preference ((name (eql :print-length)) args) + (setf *test-print-length* (first args))) + +(defmethod handle-config-preference ((name (eql :print-level)) args) + (setf *test-print-level* (first args))) + +(defmethod handle-config-preference ((name (eql :print-suite-names)) args) + (setf *test-print-testsuite-names* (first args))) + +(defmethod handle-config-preference ((name (eql :print-test-case-names)) args) + (setf *test-print-test-case-names* (first args))) + +(defmethod handle-config-preference ((name (eql :if-dribble-exists)) + args) + (setf *lift-if-dribble-exists* (first args))) + +(defmethod handle-config-preference ((name (eql :report-property)) + args) + (setf (test-result-property *test-result* (first args)) (second args))) + +(defmethod handle-config-preference ((name (eql :profiling-threshold)) + args) + (setf *profiling-threshold* (first args))) + +(defmethod handle-config-preference ((name (eql :build-report)) + args) + (declare (ignore args)) + (let* ((dest (or (test-result-property *test-result* :full-pathname) + (asdf:system-relative-pathname + (or (test-result-property *test-result* :relative-to) + 'lift) + (or (test-result-property *test-result* :name) + "report.html")))) + (format (or (test-result-property *test-result* :format) + :html)) + (unique-name (test-result-property *test-result* :unique-name))) + (when (and unique-name (not (streamp dest))) + (setf dest (unique-filename dest))) + (with-standard-io-syntax + (let ((*print-readably* nil)) + (handler-case + (cond + ((or (streamp dest) (writable-directory-p dest)) + (format *debug-io* "~&Sending report (format ~s) to ~a" + format dest) + (test-result-report + *test-result* + dest + format)) + (t + (format *debug-io* "~&Unable to write report (format ~s) to ~a" + format dest))) + (error (c) + (format *debug-io* + "Error ~a while generating report (format ~s) to ~a" + c format dest))))))) + diff --git a/external/lift/dev/copy-file.lisp b/external/lift.darcs/dev/copy-file.lisp similarity index 100% rename from external/lift/dev/copy-file.lisp rename to external/lift.darcs/dev/copy-file.lisp diff --git a/external/lift/dev/lift-interface.lisp b/external/lift.darcs/dev/lift-interface.lisp similarity index 100% rename from external/lift/dev/lift-interface.lisp rename to external/lift.darcs/dev/lift-interface.lisp diff --git a/external/lift/dev/lift-notes.lisp b/external/lift.darcs/dev/lift-notes.lisp similarity index 100% rename from external/lift/dev/lift-notes.lisp rename to external/lift.darcs/dev/lift-notes.lisp diff --git a/external/lift/dev/lift-randomized.lisp b/external/lift.darcs/dev/lift-randomized.lisp similarity index 100% rename from external/lift/dev/lift-randomized.lisp rename to external/lift.darcs/dev/lift-randomized.lisp diff --git a/external/lift/dev/lift.lisp b/external/lift.darcs/dev/lift.lisp similarity index 91% rename from external/lift/dev/lift.lisp rename to external/lift.darcs/dev/lift.lisp index 2415da5..45177f7 100644 --- a/external/lift/dev/lift.lisp +++ b/external/lift.darcs/dev/lift.lisp @@ -22,7 +22,7 @@ measure-time measure-conses with-profile-report - + ;; Variables *test-ignore-warnings?* *test-break-on-errors?* @@ -315,14 +315,12 @@ All other CLOS slot options are processed normally." (defvar *testsuite-test-count* nil "Temporary variable used to 'communicate' between deftestsuite and addtest.") (defvar *lift-debug-output* *debug-io* - "Messages from LIFT will be sent to this stream. It can set to nil or -to an output stream. It defaults to *debug-io**.") + "Messages from LIFT will be sent to this stream. It can set to nil or to an output stream. It defaults to *debug-io*.") (defvar *test-break-on-errors?* nil) (defvar *test-do-children?* t) (defparameter *test-ignore-warnings?* nil - "If true, LIFT will not cause a test to fail if a warning occurs while -the test is running. Note that this may interact oddly with ensure-warning.") + "If true, LIFT will not cause a test to fail if a warning occurs while the test is running. Note that this may interact oddly with ensure-warning.") (defparameter *test-print-when-defined?* nil) (defparameter *test-evaluate-when-defined?* t) (defparameter *test-scratchpad* nil @@ -362,16 +360,13 @@ the test is running. Note that this may interact oddly with ensure-warning.") "The current testsuite.") (defvar *lift-dribble-pathname* nil - "If bound, then test output from run-tests will be sent to this file in -in addition to *lift-standard-output*. It can be set to nil or to a pathname.") + "If bound, then test output from run-tests will be sent to this file in addition to *lift-standard-output*. It can be set to nil or to a pathname.") (defvar *lift-standard-output* *standard-output* - "Output from tests will be sent to this stream. If can set to nil or -to an output stream. It defaults to *standard-output*.") + "Output from tests will be sent to this stream. If can set to nil or to an output stream. It defaults to *standard-output*.") (defvar *lift-if-dribble-exists* :append - "Specifies what to do to any existing file at *lift-dribble-pathname*. It -can be :supersede, :append, or :error.") + "Specifies what to do to any existing file at *lift-dribble-pathname*. It can be :supersede, :append, or :error.") ;;; --------------------------------------------------------------------------- ;;; Error messages and warnings @@ -393,9 +388,7 @@ can be :supersede, :append, or :error.") "Could not find test: ~S.~S") (defparameter +run-tests-null-test-case+ - "There is no current testsuite (possibly because - none have been defined yet?). You can specify the - testsuite to test by evaluating (run-tests :suite ).") + "There is no current testsuite (possibly because none have been defined yet?). You can specify the testsuite to test by evaluating (run-tests :suite ).") (defparameter +lift-unable-to-parse-test-name-and-class+ "") @@ -412,8 +405,6 @@ can be :supersede, :append, or :error.") (:report (lambda (c s) (format s "Compile error: '~S'" (msg c))))) -;;; --------------------------------------------------------------------------- - (define-condition test-class-not-defined (lift-compile-error) ((test-class-name :reader test-class-name :initarg :test-class-name)) @@ -421,36 +412,27 @@ can be :supersede, :append, or :error.") (format s "Test class ~A not defined before it was used." (test-class-name c))))) -;;; --------------------------------------------------------------------------- - -(defun build-lift-error-message (context message &rest args) +(defun build-lift-error-message (context message &rest arguments) (format nil "~A: ~A" context - (apply #'format nil message args))) - -;;; --------------------------------------------------------------------------- + (apply #'format nil message arguments))) -(defun signal-lift-error (context message &rest args) +(defun signal-lift-error (context message &rest arguments) (let ((c (make-condition 'lift-compile-error - :lift-message (apply #'build-lift-error-message context message args)))) + :lift-message (apply #'build-lift-error-message + context message arguments)))) (unless (signal c) (error c)))) -;;; --------------------------------------------------------------------------- - -(defun report-lift-error (context message &rest args) +(defun report-lift-error (context message &rest arguments) (format *debug-io* "~&~A." - (apply #'build-lift-error-message context message args)) + (apply #'build-lift-error-message context message arguments)) (values)) -;;; --------------------------------------------------------------------------- - (defun lift-report-condition (c) (format *debug-io* "~&~A." c)) -;;; --------------------------------------------------------------------------- - (define-condition test-condition (warning) ((message :initform "" :initarg :message @@ -459,8 +441,6 @@ can be :supersede, :append, or :error.") (when (message c) (format s "~%~A" (message c)))))) -;;; --------------------------------------------------------------------------- - (define-condition ensure-failed-error (test-condition) ((assertion :initform "" :accessor assertion @@ -469,17 +449,16 @@ can be :supersede, :append, or :error.") (format s "Ensure failed: ~S ~@[(~a)~]" (assertion c) (message c))))) -;;; --------------------------------------------------------------------------- - (define-condition ensure-null-failed-error (ensure-failed-error) ((value :initform "" :accessor value - :initarg :value)) + :initarg :value) + (assertion :initform "" + :accessor assertion + :initarg :assertion)) (:report (lambda (c s) - (format s "Ensure null failed: ~S ~@[(~a)~]" - (value c) (message c))))) - -;;; --------------------------------------------------------------------------- + (format s "Ensure null failed: ~s evaluates to ~s ~@[(~a)~]" + (assertion c) (value c) (message c))))) (define-condition ensure-expected-condition (test-condition) ((expected-condition-type @@ -495,8 +474,6 @@ can be :supersede, :append, or :error.") (expected-condition-type c) (the-condition c))))) -;;; --------------------------------------------------------------------------- - (define-condition ensure-not-same (test-condition) ((first-value :accessor first-value :initarg :first-value) @@ -509,7 +486,6 @@ can be :supersede, :append, or :error.") (first-value c) (test c) (second-value c) (message c))))) -;; hacked list to take arguments in addition to args (defmacro ensure (predicate &key report arguments) "If ensure's `predicate` evaluates to false, then it will generate a test failure. You can use the `report` and `arguments` keyword parameters @@ -548,6 +524,7 @@ details." t (let ((condition (make-condition 'ensure-null-failed-error :value ,g + :assertion ',predicate ,@(when report `(:message (format nil ,report ,@arguments)))))) (if (find-restart 'ensure-failed) @@ -607,16 +584,18 @@ error, then ensure-error will generate a test failure." (when (and (consp test) (eq (first test) 'function)) (setf test (second test))) - `(progn - (loop for value in (multiple-value-list ,form) - for other-value in (multiple-value-list ,values) do - (unless (funcall ,(if test-specified-p (list 'quote test) '*lift-equality-test*) - value other-value) - (maybe-raise-not-same-condition - value other-value - ,(if test-specified-p (list 'quote test) '*lift-equality-test*) - ,report ,@arguments))) - (values t))) + (let ((block (gensym))) + `(block ,block + (loop for value in (multiple-value-list ,form) + for other-value in (multiple-value-list ,values) do + (unless (funcall ,(if test-specified-p (list 'quote test) '*lift-equality-test*) + value other-value) + (maybe-raise-not-same-condition + value other-value + ,(if test-specified-p (list 'quote test) '*lift-equality-test*) + ,report ,@arguments) + (return-from ,block nil))) + (values t)))) (defmacro ensure-different (form values &key (test nil test-specified-p) @@ -880,8 +859,8 @@ the thing being defined.") (let ((current (assoc name *current-definition*))) (if current (setf (cdr current) value) - (push (cons name value) *current-definition*))) - (values value)) + (push (cons name value) *current-definition*))) + (values value)) (defun def (name &optional (definition *current-definition*)) (when definition (cdr (assoc name definition)))) @@ -909,7 +888,7 @@ the thing being defined.") :code code))) (if current (setf (cdr current) value) - (push (cons name value) *code-blocks*)) + (push (cons name value) *code-blocks*)) (eval `(defmethod block-handler ((name (eql ',name)) value) (declare (ignorable value)) @@ -1016,12 +995,8 @@ the thing being defined.") '((push value (def :categories))) nil) -(defmacro no-handler-case (form &rest cases) - (declare (ignore cases)) - `,form) - (defmacro deftestsuite (testsuite-name superclasses slots &rest - clauses-and-options) + clauses-and-options) " Creates a testsuite named `testsuite-name` and, optionally, the code required for test setup, test tear-down and the actual test-cases. A testsuite is a collection of test-cases and other testsuites. @@ -1069,7 +1044,6 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor * :test - Define a single test case. Can be specified multiple times. * :tests - Define multiple test cases for this test suite. Can be specified multiple times. - " #+no-lift-tests `(values) @@ -1121,70 +1095,59 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor (push ',return *test-is-being-loaded?*)) (eval-when (:execute) (push ',return *test-is-being-executed?*)) + ;; remove previous methods (do this _before_ we define the class) + (remove-previous-definitions ',(def :testsuite-name)) + ,(build-test-class) (unwind-protect - (let (#+MCL (ccl:*warn-if-redefine* nil) - (*test-is-being-defined?* t)) - (no-handler-case - (progn - ;; remove previous methods (do this - ;; _before_ we define the class) - ;#+(or) - (remove-previous-definitions ',(def :testsuite-name)) - (setf *current-case-method-name* nil) - ;; and then redefine the class - ,(build-test-class) - (setf *current-suite-class-name* ',(def :testsuite-name) - (test-slots ',(def :testsuite-name)) - ',(def :slot-names) - (testsuite-dynamic-variables ',(def :testsuite-name)) - ',(def :dynamic-variables) - ;;?? issue 27: breaks 'encapsulation' of code-block mechanism - (testsuite-function-specs ',(def :testsuite-name)) - ',(def :function-specs)) - ,@(when (def :export-p) - `((export '(,(def :testsuite-name))))) - ,@(when (def :export-slots?) - `((export ',(def :direct-slot-names)))) - ;; make a place to save test-case information - (empty-test-tables ',(def :testsuite-name)) -;;; create methods - ;; setup :before - (eval-when (:load-toplevel :execute) - ,@(build-initialize-test-method) - ,@(loop for (nil . block) in *code-blocks* - when (and block - (code block) - (eq (operate-when block) :methods) - (or (not (filter block)) - (funcall (filter block)))) collect - (funcall (code block))) - ,@(when (def :dynamic-variables) - `((defmethod do-testing :around - ((suite ,(def :testsuite-name)) result fn) - (declare (ignore result fn)) - (cond ((done-dynamics? suite) - (call-next-method)) - (t - (setf (slot-value suite 'done-dynamics?) t) - (let* (,@(build-dynamics)) - (call-next-method))))))) - ;; tests - ,@(when test-list - `((let ((*test-evaluate-when-defined?* nil)) - ,@(loop for test in (nreverse test-list) collect - `(addtest (,(def :testsuite-name)) - ,@test)) - (setf *testsuite-test-count* nil)))) - ,(if *test-evaluate-when-defined?* - `(unless (or *test-is-being-compiled?* - *test-is-being-loaded?*) - (let ((*test-break-on-errors?* *test-break-on-errors?*)) - (run-tests :suite ',testsuite-name))) - `(find-class ',testsuite-name)))) - (condition (c) - (break) - (setf *testsuite-test-count* nil) - (lift-report-condition c)))) + (let ((*test-is-being-defined?* t)) + (setf *current-case-method-name* nil) + (setf *current-suite-class-name* ',(def :testsuite-name) + (test-slots ',(def :testsuite-name)) + ',(def :slot-names) + (testsuite-dynamic-variables ',(def :testsuite-name)) + ',(def :dynamic-variables) + ;;?? issue 27: breaks 'encapsulation' of code-block mechanism + (testsuite-function-specs ',(def :testsuite-name)) + ',(def :function-specs)) + ,@(when (def :export-p) + `((export '(,(def :testsuite-name))))) + ,@(when (def :export-slots?) + `((export ',(def :direct-slot-names)))) + ;; make a place to save test-case information + (empty-test-tables ',(def :testsuite-name)) + ;; create methods + ;; setup :before + ,@(build-initialize-test-method) + ,@(loop for (nil . block) in *code-blocks* + when (and block + (code block) + (eq (operate-when block) :methods) + (or (not (filter block)) + (funcall (filter block)))) collect + (funcall (code block))) + ,@(when (def :dynamic-variables) + `((defmethod do-testing :around + ((suite ,(def :testsuite-name)) result fn) + (declare (ignore result fn)) + (cond ((done-dynamics? suite) + (call-next-method)) + (t + (setf (slot-value suite 'done-dynamics?) t) + (let* (,@(build-dynamics)) + (call-next-method))))))) + ;; tests + ,@(when test-list + `((let ((*test-evaluate-when-defined?* nil)) + ,@(loop for test in (nreverse test-list) collect + `(addtest (,(def :testsuite-name)) + ,@test)) + (setf *testsuite-test-count* nil)))) + ,(if *test-evaluate-when-defined?* + `(unless (or *test-is-being-compiled?* + *test-is-being-loaded?*) + (let ((*test-break-on-errors?* *test-break-on-errors?*)) + (run-tests :suite ',testsuite-name))) + `(find-class ',testsuite-name))) ;; cleanup (setf *test-is-being-compiled?* (remove ',return *test-is-being-compiled?*)) @@ -1232,57 +1195,54 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor #+no-lift-tests `nil #-no-lift-tests - (no-handler-case - (let ((body nil) - (return (gensym)) - (options nil) - (looks-like-suite-name (looks-like-suite-name-p name)) - (looks-like-code (looks-like-code-p name))) - (cond ((and looks-like-suite-name looks-like-code) - (error "Can't disambiguate suite name from possible code.")) - (looks-like-suite-name - ;; testsuite given - (setf (def :testsuite-name) (first name) - options (rest name) - name nil body test)) - (t - ;; the 'name' is really part of the test... - (setf body (cons name test)))) - (unless (def :testsuite-name) - (when *current-suite-class-name* - (setf (def :testsuite-name) *current-suite-class-name*))) - (unless (def :testsuite-name) - (signal-lift-error 'add-test +lift-no-current-test-class+)) - (unless (or (def :deftestsuite) - (find-testsuite (def :testsuite-name))) - (signal-lift-error 'add-test +lift-test-class-not-found+ - (def :testsuite-name))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (eval-when (:compile-toplevel) - (push ',return *test-is-being-compiled?*)) - (eval-when (:load-toplevel) - (push ',return *test-is-being-loaded?*)) - (eval-when (:execute) - (push ',return *test-is-being-executed?*)) - (unwind-protect - (let ((*test-is-being-defined?* t)) - ,(build-test-test-method (def :testsuite-name) body options) - (setf *current-suite-class-name* ',(def :testsuite-name)) - (if *test-evaluate-when-defined?* - (unless (or *test-is-being-compiled?* - *test-is-being-loaded?*) - (let ((*test-break-on-errors?* (testing-interactively-p))) - (run-test))) - (values))) - ;; cleanup - (setf *test-is-being-compiled?* - (remove ',return *test-is-being-compiled?*) - *test-is-being-loaded?* - (remove ',return *test-is-being-loaded?*) - *test-is-being-executed?* - (remove ',return *test-is-being-executed?*))))) - (condition (c) - (lift-report-condition c)))) + (let ((body nil) + (return (gensym)) + (options nil) + (looks-like-suite-name (looks-like-suite-name-p name)) + (looks-like-code (looks-like-code-p name))) + (cond ((and looks-like-suite-name looks-like-code) + (error "Can't disambiguate suite name from possible code.")) + (looks-like-suite-name + ;; testsuite given + (setf (def :testsuite-name) (first name) + options (rest name) + name nil body test)) + (t + ;; the 'name' is really part of the test... + (setf body (cons name test)))) + (unless (def :testsuite-name) + (when *current-suite-class-name* + (setf (def :testsuite-name) *current-suite-class-name*))) + (unless (def :testsuite-name) + (signal-lift-error 'add-test +lift-no-current-test-class+)) + (unless (or (def :deftestsuite) + (find-testsuite (def :testsuite-name))) + (signal-lift-error 'add-test +lift-test-class-not-found+ + (def :testsuite-name))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (eval-when (:compile-toplevel) + (push ',return *test-is-being-compiled?*)) + (eval-when (:load-toplevel) + (push ',return *test-is-being-loaded?*)) + (eval-when (:execute) + (push ',return *test-is-being-executed?*)) + (unwind-protect + (let ((*test-is-being-defined?* t)) + ,(build-test-test-method (def :testsuite-name) body options) + (setf *current-suite-class-name* ',(def :testsuite-name)) + (if *test-evaluate-when-defined?* + (unless (or *test-is-being-compiled?* + *test-is-being-loaded?*) + (let ((*test-break-on-errors?* (testing-interactively-p))) + (run-test))) + (values))) + ;; cleanup + (setf *test-is-being-compiled?* + (remove ',return *test-is-being-compiled?*) + *test-is-being-loaded?* + (remove ',return *test-is-being-loaded?*) + *test-is-being-executed?* + (remove ',return *test-is-being-executed?*)))))) (defun looks-like-suite-name-p (form) (and (consp form) @@ -1453,15 +1413,13 @@ control over where in the test hierarchy the search begins." (result (make-test-result (or suite config) :multiple)) ;run-setup &allow-other-keys) - "Run all of the tests in a suite. Arguments are :suite, :result, -:do-children? and :break-on-errors?" + "Run all of the tests in a suite. Arguments are :suite, :result, :do-children? and :break-on-errors?" (remf args :suite) (remf args :break-on-errors?) (remf args :run-setup) (remf args :dribble) (cond ((and suite config) - (error "Specify either configuration file or test suite -but not both.")) + (error "Specify either configuration file or test suite but not both.")) (config (run-tests-from-file config)) ((or suite (setf suite *current-suite-class-name*)) @@ -1489,8 +1447,7 @@ but not both.")) (setf (tests-run result) (reverse (tests-run result))) (values result))) (t - (error "There is not a current test suite and neither suite -nor configuration file options were specified.")))) + (error "There is not a current test suite and neither suite nor configuration file options were specified.")))) (defun maybe-add-dribble (stream dribble-stream) (if dribble-stream @@ -1577,7 +1534,7 @@ nor configuration file options were specified.")))) (getf (test-data case) :conses) (lift-test case name))) (check-for-surprises result case name)) - (teardown-test case) + (teardown-test case) (end-test result case name))) (ensure-failed (cond) (setf problem @@ -1631,7 +1588,7 @@ nor configuration file options were specified.")))) (if (find-restart 'ensure-failed) (invoke-restart 'ensure-failed condition) (warn condition))))) - + (defun report-test-problem (problem-type result suite method condition &rest args) ;; ick diff --git a/external/lift/dev/measuring.lisp b/external/lift.darcs/dev/measuring.lisp similarity index 67% rename from external/lift/dev/measuring.lisp rename to external/lift.darcs/dev/measuring.lisp index 6d28f6e..b3edeeb 100644 --- a/external/lift/dev/measuring.lisp +++ b/external/lift.darcs/dev/measuring.lisp @@ -1,6 +1,7 @@ (in-package #:lift) -(declaim (optimize (speed 3) (safety 1))) +(eval-when (:compile-toplevel) + (declaim (optimize (speed 3) (safety 1)))) (defmacro with-measuring ((var measure-fn) &body body) (let ((initial (gensym))) @@ -35,6 +36,26 @@ (setf ,result (progn ,@body)))) (values ,result)))) +(defmacro measure-time-and-conses (&body body) + (let ((seconds (gensym)) + (conses (gensym)) + (results (gensym))) + `(let ((,seconds 0) (,conses 0) ,results) + (setf ,results (multiple-value-list + (measure ,seconds ,conses ,@body))) + (values-list (nconc (list ,seconds ,conses) + ,results))))) + +#+(or) +;; tries to handle multiple values (but fails since measure doesn't) +(defmacro measure-time-and-conses (&body body) + (let ((seconds (gensym)) + (conses (gensym))) + `(let ((,seconds 0) (,conses 0)) + (values-list (nconc (multiple-value-list + (measure ,seconds ,conses ,@body)) + (list ,seconds ,conses)))))) + (defparameter *benchmark-file* (asdf:system-relative-pathname 'lift "benchmark-data/benchmarks.log")) @@ -134,4 +155,79 @@ :accessor total-conses) (total-seconds :initform 0 :accessor total-seconds))) -|# \ No newline at end of file +|# + + +#| +(defun test-sleep (period) + (print (get-universal-time)) + (print + (mp:process-wait-with-timeout + "wait-for-delay" period + (lambda () + (sleep (1+ period))))) + (print (get-universal-time))) + +#+(or) +(test-sleep 2) +3392550276 +nil +3392550281 + +(defun test-gates (period) + (print (get-universal-time)) + (let ((g (mp:make-gate nil))) + (print + (mp:process-wait-with-timeout + "wait-for-delay" period + (lambda (gate) + (mp:gate-open-p gate)) + g))) + (print (get-universal-time))) + +#+(or) +(test-gates 2) +3392550287 +nil +3392550289 + + +|# + +#| + +(princ "ls" (shell-session-input-stream *ss*)) +(terpri (shell-session-input-stream *ss*)) +(force-output (shell-session-input-stream *ss*)) + +(read-shell-session-stream *ss* :output) + +(shell-session-command *ss* "ls") + +(shell-session-command *ss* "ps u") + +(end-shell-session *ss*) + +(compile 'read-from-stream-no-hang) + +(with-input-from-string (s "hello there") + (read-from-stream-no-hang s)) + +(read-shell-session-stream *ss* :output) + +(setf *ss* (make-shell-session)) + +(count-repetitions-in-period + (lambda () + (shell-session-command *ss* "ps u")) + 2.0) + +(count-repetitions-in-period + (lambda () + (selected-metatilities::os-processes)) + 2.0) + +|# + +#+(or) +(test-sleep-b 2) diff --git a/external/lift/dev/notes.text b/external/lift.darcs/dev/notes.text similarity index 100% rename from external/lift/dev/notes.text rename to external/lift.darcs/dev/notes.text diff --git a/external/lift.darcs/dev/packages.lisp b/external/lift.darcs/dev/packages.lisp new file mode 100644 index 0000000..4b4c63b --- /dev/null +++ b/external/lift.darcs/dev/packages.lisp @@ -0,0 +1,52 @@ +(in-package #:common-lisp-user) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package '#:lift) + (defpackage #:lift + (:use #:common-lisp) + (:import-from + #+allegro #:mop + #+clisp #:clos + #+lispworks #:clos + #+mcl #:ccl + #+cmu #:clos-mop + #+sbcl #:sb-mop + #+scl #:clos + #:class-direct-subclasses + #:class-direct-superclasses + #:class-precedence-list) + (:export + #:with-profile-report)))) + +(unless (and (find-package :asdf) + (find-symbol (symbol-name 'system-relative-pathname) :asdf) + (fboundp (find-symbol + (symbol-name 'system-relative-pathname) :asdf))) + (warn "LIFT uses asdf:system-relative-pathname which your version of ASDF +doesn't seem to include. LIFT will define these for now but you may want to consider updating to the most recent version of ASDF (see http://www.cliki.net/asdf for details).") + (intern (symbol-name 'system-source-file) :asdf) + (intern (symbol-name 'system-source-directory) :asdf) + (intern (symbol-name 'system-relative-pathname) :asdf) + (export 'asdf::system-relative-pathname :asdf) + (defun asdf::system-source-file (system-name) + (let ((system (asdf:find-system system-name))) + (make-pathname + :type "asd" + :name (asdf:component-name system) + :defaults (asdf:component-relative-pathname system)))) + + (defun asdf::system-source-directory (system-name) + (make-pathname :name nil + :type nil + :defaults (asdf::system-source-file system-name))) + + (defun asdf::system-relative-pathname (system pathname &key name type) + (let ((directory (pathname-directory pathname))) + (when (eq (car directory) :absolute) + (setf (car directory) :relative)) + (merge-pathnames + (make-pathname :name (or name (pathname-name pathname)) + :type (or type (pathname-type pathname)) + :directory directory) + (asdf::system-source-directory system))))) + \ No newline at end of file diff --git a/external/lift/dev/port.lisp b/external/lift.darcs/dev/port.lisp similarity index 87% rename from external/lift/dev/port.lisp rename to external/lift.darcs/dev/port.lisp index 1570b29..e665087 100644 --- a/external/lift/dev/port.lisp +++ b/external/lift.darcs/dev/port.lisp @@ -16,18 +16,33 @@ returns a string with the corresponding backtrace.") #+allegro (excl.osi:access directory excl.osi:*w-ok*)))) -#+allegro +;; Handle missing platforms gracefully? (defun total-bytes-allocated () + (if (fboundp '%total-bytes-allocated) + (funcall '%total-bytes-allocated) + 0)) + +#+allegro +(defun %total-bytes-allocated () (sys::gsgc-totalloc-bytes t)) #+(or digitool openmcl) -(defun total-bytes-allocated () +(defun %total-bytes-allocated () (ccl::total-bytes-allocated)) #+sbcl -(defun total-bytes-allocated () +(defun %total-bytes-allocated () (cl-user::get-bytes-consed)) +#+(or cmu scl) +(defun %total-bytes-allocated () + (ext:get-bytes-consed)) + +#+lispworks +;; thanks to Frank Schorr, via e-mail +(defun %total-bytes-allocated () + (hcl:total-allocation)) + #+mcl (defun get-backtrace (error) (with-output-to-string (s) @@ -117,7 +132,13 @@ returns a string with the corresponding backtrace.") (sb-debug:*debug-print-length* nil)) (sb-debug:backtrace most-positive-fixnum s)))) -#+cmucl +#+clisp +(defun get-backtrace (error) + (declare (ignore error)) + (with-output-to-string (s) + (system::print-backtrace :out s))) + +#+(or cmucl scl) (defun get-backtrace (error) (declare (ignore error)) (with-output-to-string (s) diff --git a/external/lift/dev/prototypes.lisp b/external/lift.darcs/dev/prototypes.lisp similarity index 100% rename from external/lift/dev/prototypes.lisp rename to external/lift.darcs/dev/prototypes.lisp diff --git a/external/lift/dev/random-testing.lisp b/external/lift.darcs/dev/random-testing.lisp similarity index 100% rename from external/lift/dev/random-testing.lisp rename to external/lift.darcs/dev/random-testing.lisp diff --git a/external/lift/dev/reports.lisp b/external/lift.darcs/dev/reports.lisp similarity index 88% rename from external/lift/dev/reports.lisp rename to external/lift.darcs/dev/reports.lisp index b02b3e7..9bd29d0 100644 --- a/external/lift/dev/reports.lisp +++ b/external/lift.darcs/dev/reports.lisp @@ -15,7 +15,7 @@ For *debug-io*, *query-io*: a bidirectional stream. #| (progn - (setf (test-result-property *test-result* :style-sheet) "style.css") + (setf (test-result-property *test-result* :style-sheet) "test-style.css") (setf (test-result-property *test-result* :title) "Test Results X") (setf (test-result-property *test-result* :if-exists) :supersede) (test-result-report *test-result* #p"/tmp/report.html" :html)) @@ -68,23 +68,31 @@ run-test-internal (add test-data to tests-run of result) |# +;; when it doubt, add a special +(defvar *report-environment* nil + "Used internally by LIFT reports.") + +(defun make-report-environment () + nil) + ;; env variables need to be part saved in result (defun test-result-report (result output format) - (cond ((or (stringp output) - (pathnamep output)) - (with-open-file (stream - output - :direction :output - :if-does-not-exist :create - :if-exists (or (test-result-property - result :if-exists) - :error)) - (%test-result-report-stream result stream format))) - ((streamp output) - (%test-result-report-stream result output format)) - (t - (error "Don't know how to send a report to ~s" output)))) + (let ((*report-environment* (make-report-environment))) + (cond ((or (stringp output) + (pathnamep output)) + (with-open-file (stream + output + :direction :output + :if-does-not-exist :create + :if-exists (or (test-result-property + result :if-exists) + :error)) + (%test-result-report-stream result stream format))) + ((streamp output) + (%test-result-report-stream result output format)) + (t + (error "Don't know how to send a report to ~s" output))))) (defun %test-result-report-stream (result stream format) (start-report-output result stream format) @@ -191,12 +199,14 @@ run-test-internal (length (failures result)) (length (errors result))))) -#| - (print (start-time-universal result) stream) - (print (end-time-universal result) stream) - (print (real-start-time result) stream) - (print (real-end-time result) stream) -|# + (when (or (expected-errors result) (expected-failures result)) + (format stream "~&

~[~:;~:*Expected failure~:p: ~a~]~[~:;, ~]~[~:;~:*Expected error~:p: ~a~]

~%" + (length (expected-failures result)) + ;; zero if only one or the other (so we don't need a separator...) + (* (length (expected-failures result)) + (length (expected-errors result))) + (length (expected-errors result)))) + (when (and (numberp (end-time-universal result)) (numberp (start-time-universal result))) (format stream "~&

Testing took: ~:d seconds

" @@ -313,15 +323,15 @@ run-test-internal (format stream "~&
") (let ((problem (getf datum :problem))) (cond ((typep problem 'test-failure) - (format stream "~&~a [*]" - test-name - (details-link stream test-name)) + (format stream "~&~a" + (details-link stream suite test-name) + test-name) (format stream "~&failure" )) ((typep problem 'test-error) - (format stream "~&~a [during ~a]" + (format stream "~&~a [during ~a]" + (details-link stream suite test-name) test-name - (details-link stream test-name) (test-step problem)) (format stream "~&error")) (t @@ -339,16 +349,33 @@ run-test-internal (when current-suite (format stream "
")))) -(defun details-link (stream name) +(defun get-details-links-table () + (let ((hash (getf *report-environment* :details-links))) + (or hash + (setf (getf *report-environment* :details-links) + (make-hash-table :test 'equal))))) + +#+(or) +(get-details-links-table) + +(defun details-link (stream suite name) (declare (ignore stream)) - (make-pathname :name (format nil "details-~a" name) - :type "html")) + (let* ((hash (get-details-links-table))) + (or (gethash (cons suite name) hash) + (progn + (incf (getf *report-environment* :details-links-count 0)) + (setf (gethash (cons suite name) hash) + (make-pathname + :name (format nil "details-~a" + (getf *report-environment* :details-links-count)) + :type "html")))))) (defmethod end-report-output (result stream (format (eql :html))) (let ((style-sheet (test-result-property result :style-sheet))) (when style-sheet (ignore-errors - (copy-file (asdf:system-relative-pathname 'lift "resources/style.css") + (copy-file (asdf:system-relative-pathname + 'lift "resources/test-style.css") (make-pathname :name (pathname-name style-sheet) :type (pathname-type style-sheet) @@ -369,11 +396,13 @@ run-test-internal (format stream "~&")) (defmethod generate-detailed-reports (result stream (format (eql :html))) - (loop for (nil test-name datum) in (tests-run result) + (loop for (suite test-name datum) in (tests-run result) when (getf datum :problem) do - (with-open-file (out (merge-pathnames - (details-link stream test-name) - stream) + (let ((output-pathname (merge-pathnames + (details-link stream suite test-name) + stream))) + (ensure-directories-exist output-pathname) + (with-open-file (out output-pathname :direction :output :if-does-not-exist :create :if-exists :supersede) @@ -392,8 +421,7 @@ run-test-internal (with-output-to-string (s) (print-test-problem "" (getf datum :problem) s)))) (format out "~&") - (html-footer out)) - )) + (html-footer out))))) #+(or) (defmethod summarize-test-environment (result stream format) diff --git a/external/lift/examples/basic-examples.lisp b/external/lift.darcs/examples/basic-examples.lisp similarity index 100% rename from external/lift/examples/basic-examples.lisp rename to external/lift.darcs/examples/basic-examples.lisp diff --git a/external/lift/examples/random-testing.lisp b/external/lift.darcs/examples/random-testing.lisp similarity index 100% rename from external/lift/examples/random-testing.lisp rename to external/lift.darcs/examples/random-testing.lisp diff --git a/external/lift.darcs/lift-standard.config b/external/lift.darcs/lift-standard.config new file mode 100644 index 0000000..5dba80a --- /dev/null +++ b/external/lift.darcs/lift-standard.config @@ -0,0 +1,39 @@ +;;; configuration for LIFT tests + +;; settings +(:if-dribble-exists :supersede) +(:dribble "lift.dribble") +(:print-length 10) +(:print-level 5) +(:print-test-case-names t) + + +;; suites to run +(lift-test) + +;; report properties +(:report-property :title "LIFT | Test results") +(:report-property :relative-to lift-test) + + + +(:report-property :style-sheet "test-style.css") +(:report-property :if-exists :supersede) +(:report-property :format :html) +(:report-property :name "test-results/test-report.html") +(:report-property :unique-name t) +(:build-report) + +(:report-property :unique-name t) +(:report-property :format :describe) +(:report-property :name "test-results/test-report.txt") +(:build-report) + + +(:report-property :format :save) +(:report-property :name "test-results/test-report.sav") +(:build-report) + +(:report-property :format :describe) +(:report-property :full-pathname *standard-output*) +(:build-report) diff --git a/external/lift/lift-test.asd b/external/lift.darcs/lift-test.asd similarity index 100% rename from external/lift/lift-test.asd rename to external/lift.darcs/lift-test.asd diff --git a/external/lift/lift.asd b/external/lift.darcs/lift.asd similarity index 86% rename from external/lift/lift.asd rename to external/lift.darcs/lift.asd index f72548b..d5d3667 100644 --- a/external/lift/lift.asd +++ b/external/lift.darcs/lift.asd @@ -2,7 +2,7 @@ (in-package #:asdf-lift) (defsystem lift - :version "1.3.1" + :version "1.3.5" :author "Gary Warren King " :maintainer "Gary Warren King " :licence "MIT Style License; see file COPYING for details" @@ -25,7 +25,7 @@ (:file "measuring" :depends-on ("packages")) (:file "config" - :depends-on ("port")) + :depends-on ("port" "lift")) (:file "reports" :depends-on ("port")) #+Ignore @@ -39,11 +39,11 @@ ((:static-file "index.lml")))))) :in-order-to ((test-op (load-op lift-test))) + :depends-on () :perform (test-op :after (op c) - (describe - (funcall (intern (symbol-name '#:run-tests) :lift) - :suite '#:lift-test))) - :depends-on ()) + (funcall + (intern (symbol-name '#:run-tests) :lift) + :config :generic))) (defmethod operation-done-p ((o test-op) (c (eql (find-system 'lift)))) diff --git a/external/lift/resources/style.css b/external/lift.darcs/resources/test-style.css similarity index 100% rename from external/lift/resources/style.css rename to external/lift.darcs/resources/test-style.css diff --git a/external/lift/test/equality-tests.lisp b/external/lift.darcs/test/equality-tests.lisp similarity index 97% rename from external/lift/test/equality-tests.lisp rename to external/lift.darcs/test/equality-tests.lisp index da1f36c..01a9965 100644 --- a/external/lift/test/equality-tests.lisp +++ b/external/lift.darcs/test/equality-tests.lisp @@ -1,4 +1,4 @@ -(in-package lift) +(in-package #:lift) (deftestsuite equality-test-1 () () diff --git a/external/lift/test/finding-tests.lisp b/external/lift.darcs/test/finding-tests.lisp similarity index 100% rename from external/lift/test/finding-tests.lisp rename to external/lift.darcs/test/finding-tests.lisp diff --git a/external/lift/test/lift-test.lisp b/external/lift.darcs/test/lift-test.lisp similarity index 85% rename from external/lift/test/lift-test.lisp rename to external/lift.darcs/test/lift-test.lisp index d715a88..3e37c5f 100644 --- a/external/lift/test/lift-test.lisp +++ b/external/lift.darcs/test/lift-test.lisp @@ -15,7 +15,8 @@ See file COPYING for license #:test-mode #:test-interactive? #:make-test-result - #:testsuite-test-count)) + #:testsuite-test-count + #:*test-environment*)) (in-package #:lift-test) (deftestsuite lift-test () ()) @@ -43,11 +44,10 @@ See file COPYING for license (let ((tr (run-test :suite 'lift-test-ensure-helper :name 'simple-ensure-test-1))) (ensure-same (length (tests-run tr)) 1) - (ensure-same (failures tr) nil) - (ensure-same (errors tr) nil) + (ensure-null (failures tr)) + (ensure-null (errors tr)) (ensure-same (test-mode tr) :single) -; (ensure-same (test-interactive? tr) nil) - (ensure-same (mapcar #'first (tests-run tr)) + (ensure-same (mapcar #'second (tests-run tr)) '(lift-test::simple-ensure-test-1)))) ;;; --------------------------------------------------------------------------- @@ -62,8 +62,8 @@ See file COPYING for license :name 'simple-ensure-test-2))) (ensure-same (length (tests-run tr)) 1 :report "Number of tests-run") (ensure-same (length (failures tr)) 1 :report "Number of failures") - (ensure-same (errors tr) nil :report "Number of errors") - (ensure-same (mapcar #'first (tests-run tr)) + (ensure-null (errors tr) :report "Number of errors") + (ensure-same (mapcar #'second (tests-run tr)) '(lift-test::simple-ensure-test-2)))) ;;; --------------------------------------------------------------------------- @@ -79,7 +79,7 @@ See file COPYING for license (ensure-same (length (tests-run tr)) 1) (ensure-same (length (failures tr)) 0) (ensure-same (length (errors tr)) 1) - (ensure-same (mapcar #'first (tests-run tr)) + (ensure-same (mapcar #'second (tests-run tr)) '(lift-test::simple-ensure-test-3)))) @@ -226,7 +226,7 @@ See file COPYING for license (ensure-same *test-notepad* '(:a-1 :a :a-1 :a))) (addtest (test-single-setup) - test-a-single-setup-2 + test-a-single-setup-3 (setf *test-notepad* nil) (run-tests :suite 'test-single-setup-child-a-1 :run-setup :once-per-suite @@ -275,6 +275,7 @@ See file COPYING for license (deftestsuite lift-test-environment-pristine (lift-test) () (:setup (setf *test-environment* nil))) + (deftestsuite lift-test-environment-pristine-helper () ((a 2) (b (* a a)))) @@ -283,7 +284,8 @@ See file COPYING for license do-it (ensure-same (* a a) b)) -(addtest (lift-test-environment-pristine) +(addtest (lift-test-environment-pristine + :expected-failure "This is no longer guarenteed; I'm not sure yet whether or not this is a good thing.") test-1 (run-test :suite 'lift-test-environment-pristine-helper :name 'do-it) (ensure (null *test-environment*))) @@ -306,7 +308,7 @@ See file COPYING for license test-1 (ensure-same (testsuite-test-count 'test-creating-multiple-tests-helper) 2)) - +;;;;; (defvar *dynamics-before-setup* :dbs) @@ -332,3 +334,57 @@ See file COPYING for license (ensure-same (reverse *test-notepad*) '(:dynamics :slot :setup :test))) + +;;;;; +;;; inherited functions + +(deftestsuite test-inherited-functions-helper () + () + (:function + (really? (a b c) + (ensure-same (+ a b) c :test '=)))) + +(deftestsuite test-inherited-functions-pos (test-inherited-functions-helper) + () + (:tests ((really? 1 2 3)) + ((really? 4 5 9)))) + +(deftestsuite test-inherited-functions-neg (test-inherited-functions-helper) + () + (:tests ((really? -4 -2 -6)) + ((really? -1 -1 -2)))) + +(deftestsuite test-inherited-functions (lift-test) + ()) + +(addtest (test-inherited-functions) + one + (let ((tr (run-tests :suite 'test-inherited-functions-helper))) + (ensure-same (length (tests-run tr)) 4) + (ensure-null (failures tr)) + (ensure-null (errors tr)))) + + +;;;;; +;;; slot initialization takes place with every setup + +(deftestsuite test-initialize-slots-helper () + ((slot (incf *test-notepad*)))) + +(addtest (test-initialize-slots-helper) + one + (ensure t)) + +(addtest (test-initialize-slots-helper) + two + (ensure-null nil)) + +(deftestsuite test-initialize-slots (lift-test) + () + (:setup (setf *test-notepad* 0))) + +(addtest (test-initialize-slots) + slot-initform-evaluated-every-time + (let ((tr (run-tests :suite 'test-initialize-slots-helper))) + (ensure-same (length (tests-run tr)) 2) + (ensure-same *test-notepad* 2 :test '=))) diff --git a/external/lift/test/test-dynamic-variables.lisp b/external/lift.darcs/test/test-dynamic-variables.lisp similarity index 100% rename from external/lift/test/test-dynamic-variables.lisp rename to external/lift.darcs/test/test-dynamic-variables.lisp diff --git a/external/lift/test/test-prototypes.lisp b/external/lift.darcs/test/test-prototypes.lisp similarity index 100% rename from external/lift/test/test-prototypes.lisp rename to external/lift.darcs/test/test-prototypes.lisp diff --git a/external/lift/test/test-timeout.lisp b/external/lift.darcs/test/test-timeout.lisp similarity index 100% rename from external/lift/test/test-timeout.lisp rename to external/lift.darcs/test/test-timeout.lisp diff --git a/external/lift/test/tests-in-progress.lisp b/external/lift.darcs/test/tests-in-progress.lisp similarity index 92% rename from external/lift/test/tests-in-progress.lisp rename to external/lift.darcs/test/tests-in-progress.lisp index 5a02015..bb5661c 100644 --- a/external/lift/test/tests-in-progress.lisp +++ b/external/lift.darcs/test/tests-in-progress.lisp @@ -153,20 +153,5 @@ the methods that should be run to do the tests for this test.")) -;;; inherited functions -(deftestsuite test-+ () - () - (:function - (really? (a b c) - (ensure-same (+ a b) c :test '=)))) -(deftestsuite test-+-pos (test-+) - () - (:tests ((really? 1 2 3)) - ((really? 4 5 9)))) - -(deftestsuite test-+-neg (test-+) - () - (:tests ((really? -4 -2 -6)) - ((really? -1 -1 -2)))) diff --git a/external/lift/website/source/assets/ILC-2003-Presentation.pdf b/external/lift.darcs/website/source/assets/ILC-2003-Presentation.pdf similarity index 100% rename from external/lift/website/source/assets/ILC-2003-Presentation.pdf rename to external/lift.darcs/website/source/assets/ILC-2003-Presentation.pdf diff --git a/external/lift/website/source/assets/ILC-2003-Presentation.swf b/external/lift.darcs/website/source/assets/ILC-2003-Presentation.swf similarity index 100% rename from external/lift/website/source/assets/ILC-2003-Presentation.swf rename to external/lift.darcs/website/source/assets/ILC-2003-Presentation.swf diff --git a/external/lift/website/source/assets/test-framework.pdf b/external/lift.darcs/website/source/assets/test-framework.pdf similarity index 100% rename from external/lift/website/source/assets/test-framework.pdf rename to external/lift.darcs/website/source/assets/test-framework.pdf diff --git a/external/lift/website/source/faq.md b/external/lift.darcs/website/source/faq.md similarity index 100% rename from external/lift/website/source/faq.md rename to external/lift.darcs/website/source/faq.md diff --git a/external/lift.darcs/website/source/footer.md b/external/lift.darcs/website/source/footer.md new file mode 100644 index 0000000..5ec4d40 --- /dev/null +++ b/external/lift.darcs/website/source/footer.md @@ -0,0 +1,13 @@ + diff --git a/external/lift/website/source/glossary.md b/external/lift.darcs/website/source/glossary.md similarity index 100% rename from external/lift/website/source/glossary.md rename to external/lift.darcs/website/source/glossary.md diff --git a/external/lift/website/source/header.md b/external/lift.darcs/website/source/header.md similarity index 69% rename from external/lift/website/source/header.md rename to external/lift.darcs/website/source/header.md index 8926b10..9314281 100644 --- a/external/lift/website/source/header.md +++ b/external/lift.darcs/website/source/header.md @@ -1,6 +1,7 @@ {set-property html yes} -{set-property style-sheet style} +{set-property style-sheet "http://common-lisp.net/project/cl-containers/shared/style.css"} {set-property author "Gary Warren King"} +{set-property title "LIFT - the LIsp Framework for Testing"} [del.icio.us]: http://del.icio.us [Arnesi]: http://common-lisp.net/project/bese/arnesi.html @@ -27,6 +28,11 @@ [SUnit]: http://www.sunit.com/ [JUnit]: http://www.junit.com/ -