Permalink
Browse files

Added port and random-testing. The first provides get-backtrace. The …

…second provides ensure-random-cases and ensure-random-cases+.

darcs-hash:20061231201057-3cc5d-93ca122e0e00a00c0fa8fe781cab5ef1e4be89ea.gz
  • Loading branch information...
gwkkwg committed Dec 31, 2006
1 parent f20fabf commit b75714549a54f56b3b352df474d02e54a209a699
Showing with 240 additions and 0 deletions.
  1. +107 −0 dev/port.lisp
  2. +132 −0 dev/random-testing.lisp
  3. +1 −0 examples/random-testing.lisp
View
@@ -0,0 +1,107 @@
+(in-package #:lift)
+
+(setf (documentation 'get-backtrace 'function)
+ "This is the function that is used internally by Hunchentoot to
+show or log backtraces. It accepts a condition object ERROR and
+returns a string with the corresponding backtrace.")
+
+#+mcl
+(defun get-backtrace (error)
+ (with-output-to-string (s)
+ (let ((*debug-io* s))
+ (format *terminal-io* "~
+~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
+ error)
+ (ccl:print-call-history :detailed-p nil))))
+
+#+allegro
+(defun get-backtrace (error)
+ (with-output-to-string (s)
+ (with-standard-io-syntax
+ (let ((*print-readably* nil)
+ (*print-miser-width* 40)
+ (*print-pretty* t)
+ (tpl:*zoom-print-circle* t)
+ (tpl:*zoom-print-level* nil)
+ (tpl:*zoom-print-length* nil))
+ (cl:ignore-errors
+ (format *terminal-io* "~
+~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
+ error))
+ (cl:ignore-errors
+ (let ((*terminal-io* s)
+ (*standard-output* s))
+ (tpl:do-command "zoom"
+ :from-read-eval-print-loop nil
+ :count t
+ :all t)))))))
+
+#+(or)
+(defun zoom-to-stream (condition output)
+ (with-standard-io-syntax
+ (let ((*print-readably* nil)
+ (*print-miser-width* 40)
+ (*print-pretty* t)
+ (tpl:*zoom-print-circle* t)
+ (tpl:*zoom-print-level* nil)
+ (tpl:*zoom-print-length* nil))
+ (ignore-errors
+ (format *terminal-io* "Creating backtrace for ~a to ~a"
+ condition output))
+ (flet ((zoom (s)
+ (ignore-errors
+ (let ((*terminal-io* s)
+ (*standard-output* s))
+ (tpl:do-command "zoom"
+ :from-read-eval-print-loop nil
+ :count t :all t)))))
+ (cond ((streamp output)
+ (zoom output))
+ (t
+ (ensure-directories-exist output)
+ (with-open-file (s output :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (zoom s))))))))
+
+#+lispworks
+(defun get-backtrace (error)
+ (declare (ignore error))
+ (with-output-to-string (s)
+ (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many most-positive-fixnum))
+ (*debug-io* s)
+ (dbg:*debug-print-level* nil)
+ (dbg:*debug-print-length* nil))
+ (dbg:bug-backtrace nil))))
+
+#+sbcl
+;; determine how we're going to access the backtrace in the next
+;; function
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug)
+ (pushnew :hunchentoot-sbcl-debug-print-variable-alist *features*)))
+
+#+sbcl
+(defun get-backtrace (error)
+ (declare (ignore error))
+ (with-output-to-string (s)
+ #+:hunchentoot-sbcl-debug-print-variable-alist
+ (let ((sb-debug:*debug-print-variable-alist*
+ (list* '(*print-level* . nil)
+ '(*print-length* . nil)
+ sb-debug:*debug-print-variable-alist*)))
+ (sb-debug:backtrace most-positive-fixnum s))
+ #-:hunchentoot-sbcl-debug-print-variable-alist
+ (let ((sb-debug:*debug-print-level* nil)
+ (sb-debug:*debug-print-length* nil))
+ (sb-debug:backtrace most-positive-fixnum s))))
+
+#+cmucl
+(defun get-backtrace (error)
+ (declare (ignore error))
+ (with-output-to-string (s)
+ (let ((debug:*debug-print-level* nil)
+ (debug:*debug-print-length* nil))
+ (debug:backtrace most-positive-fixnum s))))
+
+
View
@@ -0,0 +1,132 @@
+(in-package #:lift)
+
+(export '(suite
+ ensure-random-cases-failure
+ random-instance-for-suite
+ defrandom-instance
+ ensure-random-cases
+ ensure-random-cases+
+ random-element
+ random-number
+ an-integer
+ a-double-float
+ a-single-float
+ a-symbol))
+
+;; we redefine the class and possibly method each time, ick.
+
+(define-condition ensure-random-cases-failure (test-condition)
+ ((total :initarg :total :initform 0)
+ (problems :initarg :problems :initform nil))
+ (:report (lambda (condition stream)
+ (format stream "Ensure-random-cases: ~d out of ~d failed. Failing values are: ~{~s~^, ~}"
+ (length (slot-value condition 'problems))
+ (slot-value condition 'total)
+ (slot-value condition 'problems)))))
+
+(defgeneric random-instance-for-suite (thing suite))
+
+(defmacro defrandom-instance (instance-type suite &body body)
+ `(progn
+ (defclass ,instance-type () ())
+ (defvar ,(intern (format nil "+~a+" instance-type) :lift)
+ (make-instance ',instance-type))
+ (defmethod random-instance-for-suite
+ ((thing ,instance-type) (suite ,(if suite suite t)))
+ ,@body)))
+
+(defmacro ensure-random-cases (count (&rest vars-and-types)
+ &body body)
+ (let ((problems (gensym)))
+ (flet ((intern-type (type)
+ (intern (format nil "+~a+" type) :lift)))
+ `(let ((,problems nil))
+ (loop repeat ,count do
+ (princ #\.)
+ (let (,@(mapcar
+ (lambda (var-and-type)
+ `(,(first var-and-type)
+ (random-instance-for-suite
+ ,(intern-type (second var-and-type))
+ *current-test*)))
+ vars-and-types))
+ (restart-case
+ (progn ,@body)
+ (ensure-failed (cond)
+ (push (list ,@(mapcar
+ (lambda (var-and-type)
+ `(list ',(first var-and-type)
+ ,(first var-and-type)))
+ vars-and-types)) ,problems)))))
+ (when ,problems
+ (let ((condition (make-condition
+ 'ensure-random-cases-failure
+ :total ,count
+ :problems ,problems)))
+ (if (find-restart 'ensure-failed)
+ (invoke-restart 'ensure-failed condition)
+ (warn condition))))))))
+
+(defmacro ensure-random-cases+ (count (&rest vars) (&rest case-form) &body body)
+ (let ((case (gensym))
+ (total (gensym))
+ (problems (gensym)))
+ `(let ((,problems nil) (,total 0))
+ (loop repeat ,count do
+ (incf ,total)
+ (destructuring-bind ,vars ,case-form
+ (restart-case
+ (progn ,@body)
+ (ensure-failed (cond)
+ (declare (ignore cond))
+ (push ,case ,problems)))))
+ (when ,problems
+ (let ((condition (make-condition
+ 'ensure-cases-failure
+ :total ,total
+ :problems ,problems)))
+ (if (find-restart 'ensure-failed)
+ (invoke-restart 'ensure-failed condition)
+ (warn condition)))))))
+
+;;; merge with deftestsuite macro
+(pushnew :random-instance *deftest-clauses*)
+
+(add-code-block
+ :random-instance 2 :methods
+ (lambda () (def :random-instances))
+ '((push (cleanup-parsed-parameter value) (def :random-instances)))
+ 'build-random-instances-method)
+
+(defun build-random-instances-method ()
+ `(progn ,@(mapcar (lambda (instance)
+ (let ((atype (first instance))
+ (body (second instance)))
+ `(defrandom-instance ,atype test-mixin ,body)))
+ (def :random-instances))))
+
+(defgeneric random-number (suite min max))
+
+(defgeneric random-element (suite sequence))
+
+(defmethod random-number (suite min max)
+ (+ min (random (- max min))))
+
+(defmethod random-element (suite sequence)
+ (elt sequence (random-number suite 0 (1- (length sequence)))))
+
+(defrandom-instance an-integer test-mixin
+ (random-number suite -100 100))
+
+(defrandom-instance a-single-float test-mixin
+ (random-number suite -100s0 100.0s0))
+
+(defrandom-instance a-double-float test-mixin
+ (random-number suite -100d0 100.0d0))
+
+(defrandom-instance a-symbol test-mixin
+ (random-element suite '(a hello a-c d_f |MiXeD|
+ -2<>#$%#)))
+
+
+
@@ -29,3 +29,4 @@
(deftestsuite small-positive-integer-math (integer-math)
()
(:random-instance an-integer (1+ (random 10))))
+

0 comments on commit b757145

Please sign in to comment.