sbcl stuff
This commit is contained in:
Ian Keane
parent
1d1dbc34df
commit
5d91dbb667
335 changed files with 119806 additions and 1 deletions
|
|
@ -0,0 +1,6 @@
|
|||
(defpackage trivial-gray-streams-test
|
||||
(:use :cl #:trivial-gray-streams)
|
||||
(:shadow #:method)
|
||||
(:export #:run-tests
|
||||
#:failed-test-names))
|
||||
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
(ql:quickload :trivial-gray-streams)
|
||||
(ql:quickload :test-grid-agent)
|
||||
(ql:quickload :cl-fad)
|
||||
(in-package :cl-user)
|
||||
|
||||
(defparameter *abcl* (make-instance 'lisp-exe:abcl
|
||||
:java-exe-path "C:\\Program Files\\Java\\jdk1.6.0_26\\bin\\java"
|
||||
:abcl-jar-path "C:\\Users\\anton\\unpacked\\abcl\\abcl-bin-1.1.0\\abcl.jar"))
|
||||
(defparameter *clisp* (make-instance 'lisp-exe:clisp :exe-path "clisp"))
|
||||
(defparameter *ccl-1.8-x86* (make-instance 'lisp-exe:ccl
|
||||
:exe-path "C:\\Users\\anton\\unpacked\\ccl\\ccl-1.8-windows\\wx86cl.exe"))
|
||||
(defparameter *ccl-1.8-x86-64* (make-instance 'lisp-exe:ccl
|
||||
:exe-path "C:\\Users\\anton\\unpacked\\ccl\\ccl-1.8-windows\\wx86cl64.exe"))
|
||||
(defparameter *sbcl-1.1.0.45* (make-instance 'lisp-exe:sbcl :exe-path "C:\\Program Files (x86)\\Steel Bank Common Lisp\\1.1.0.45\\run.bat"))
|
||||
(defparameter *sbcl-win-branch-64* (make-instance 'lisp-exe:sbcl :exe-path "C:\\Program Files\\Steel Bank Common Lisp\\1.1.0.36.mswinmt.1201-284e340\\run.bat"))
|
||||
(defparameter *sbcl-win-branch-32* (make-instance 'lisp-exe:sbcl :exe-path "C:\\Program Files (x86)\\Steel Bank Common Lisp\\1.1.0.36.mswinmt.1201-284e340\\run.bat"))
|
||||
(defparameter *ecl-bytecode* (make-instance 'lisp-exe:ecl
|
||||
:exe-path "C:\\Users\\anton\\projects\\ecl\\bin\\ecl.exe"
|
||||
:compiler :bytecode))
|
||||
(defparameter *ecl-lisp-to-c* (make-instance 'lisp-exe:ecl
|
||||
:exe-path "C:\\Users\\anton\\projects\\ecl\\bin\\ecl.exe"
|
||||
:compiler :lisp-to-c))
|
||||
(defparameter *acl* (make-instance 'lisp-exe:acl :exe-path "C:\\Program Files (x86)\\acl90express\\alisp.exe"))
|
||||
|
||||
(defun run-on-many-lisps (run-description test-run-dir quicklisp-dir lisps)
|
||||
(ensure-directories-exist test-run-dir)
|
||||
(let ((fasl-root (merge-pathnames "fasl/" test-run-dir)))
|
||||
(labels ((log-name (lisp)
|
||||
(substitute #\- #\.
|
||||
;; Substitute dots by hypens if our main process is CCL, it
|
||||
;; prepends the > symbol before dots;
|
||||
;; for example: 1.1.0.36.mswinmt.1201-284e340 => 1>.1>.0>.36>.mswinmt.1201-284e340
|
||||
;; When we pass such a pathname to another lisps, they can't handle it.
|
||||
(string-downcase (tg-agent::implementation-identifier lisp))))
|
||||
(fasl-dir (lisp)
|
||||
(merge-pathnames (format nil "~A/" (log-name lisp))
|
||||
fasl-root))
|
||||
(run (lisp)
|
||||
(let* ((lib-result (tg-agent::proc-run-libtest lisp
|
||||
:trivial-gray-streams
|
||||
run-description
|
||||
(merge-pathnames (log-name lisp) test-run-dir)
|
||||
quicklisp-dir
|
||||
(fasl-dir lisp)))
|
||||
(status (getf lib-result :status)))
|
||||
(if (listp status)
|
||||
(getf status :failed-tests)
|
||||
status))))
|
||||
(let ((results (mapcar (lambda (lisp)
|
||||
(list (tg-agent::implementation-identifier lisp)
|
||||
(run lisp)))
|
||||
lisps)))
|
||||
(tg-utils::write-to-file results (merge-pathnames "resutls.lisp" test-run-dir))
|
||||
(cl-fad:delete-directory-and-files fasl-root)
|
||||
results))))
|
||||
|
||||
(run-on-many-lisps '(:lib-world "quicklisp 2013-02-17 + trivial-gray-streams.head"
|
||||
:contact-email "avodonosov@yandex.ru")
|
||||
"C:\\Users\\anton\\projects\\trivial-gray-streams\\test\\"
|
||||
(merge-pathnames "quicklisp/" (user-homedir-pathname))
|
||||
(list *sbcl-1.1.0.45* *sbcl-win-branch-64* *sbcl-win-branch-32*
|
||||
*abcl*
|
||||
*clisp*
|
||||
*ccl-1.8-x86* *ccl-1.8-x86-64*
|
||||
*ecl-bytecode* *ecl-lisp-to-c*
|
||||
*acl*))
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
(in-package :trivial-gray-streams-test)
|
||||
|
||||
;;; test framework
|
||||
|
||||
#|
|
||||
Used like this:
|
||||
|
||||
(list (test (add) (assert (= 5 (+ 2 2))))
|
||||
(test (mul) (assert (= 4 (* 2 2))))
|
||||
(test (subst) (assert (= 3 (- 4 2)))))
|
||||
|
||||
=> ;; list of test results, 2 failed 1 passed
|
||||
(#<TEST-RESULT ADD :FAIL The assertion (= 5 (+ 2 2)) failed.>
|
||||
#<TEST-RESULT MUL :OK>
|
||||
#<TEST-RESULT SUBST :FAIL The assertion (= 3 (- 4 2)) failed.>)
|
||||
|
||||
|#
|
||||
|
||||
(defclass test-result ()
|
||||
((name :type symbol
|
||||
:initarg :name
|
||||
:initform (error ":name is requierd")
|
||||
:accessor name)
|
||||
(status :type (or (eql :ok) (eql :fail))
|
||||
:initform :ok
|
||||
:initarg :status
|
||||
:accessor status)
|
||||
(cause :type (or null condition)
|
||||
:initform nil
|
||||
:initarg :cause
|
||||
:accessor cause)))
|
||||
|
||||
(defun failed-p (test-result)
|
||||
(eq (status test-result) :fail))
|
||||
|
||||
(defmethod print-object ((r test-result) stream)
|
||||
(print-unreadable-object (r stream :type t)
|
||||
(format stream "~S ~S~@[ ~A~]" (name r) (status r) (cause r))))
|
||||
|
||||
(defparameter *allow-debugger* nil)
|
||||
|
||||
(defun test-impl (name body-fn)
|
||||
(flet ((make-result (status &optional cause)
|
||||
(make-instance 'test-result :name name :status status :cause cause)))
|
||||
(handler-bind ((serious-condition
|
||||
(lambda (c)
|
||||
(unless *allow-debugger*
|
||||
(format t "FAIL: ~A~%" c)
|
||||
(let ((result (make-result :fail c)))
|
||||
(return-from test-impl result))))))
|
||||
(format t "Running test ~S... " name)
|
||||
(funcall body-fn)
|
||||
(format t "OK~%")
|
||||
(make-result :ok))))
|
||||
|
||||
(defmacro test ((name) &body body)
|
||||
"If the BODY signals a SERIOUS-CONDITION
|
||||
this macro returns a failed TEST-RESULT; otherwise
|
||||
returns a successfull TEST-RESULT."
|
||||
`(test-impl (quote ,name) (lambda () ,@body)))
|
||||
|
|
@ -0,0 +1,213 @@
|
|||
(in-package :trivial-gray-streams-test)
|
||||
|
||||
;;; assert-invoked - a tool to check that specified method with parameters has
|
||||
;;; been invoked during execution of a code body
|
||||
|
||||
(define-condition invoked ()
|
||||
((method :type (or symbol cons) ;; cons is for (setf method)
|
||||
:accessor method
|
||||
:initarg :method
|
||||
:initform (error ":method is required"))
|
||||
(args :type list
|
||||
:accessor args
|
||||
:initarg :args
|
||||
:initform nil)))
|
||||
|
||||
(defun assert-invoked-impl (method args body-fn)
|
||||
(let ((expected-invocation (cons method args))
|
||||
(actual-invocations nil))
|
||||
(handler-bind ((invoked (lambda (i)
|
||||
(let ((invocation (cons (method i) (args i))))
|
||||
(when (equalp invocation expected-invocation)
|
||||
(return-from assert-invoked-impl nil))
|
||||
(push invocation actual-invocations)))))
|
||||
(funcall body-fn))
|
||||
(let ((*package* (find-package :keyword))) ; ensures package prefixes are printed
|
||||
(error "expected invocation: ~(~S~) actual: ~{~(~S~)~^, ~}"
|
||||
expected-invocation (reverse actual-invocations)))))
|
||||
|
||||
(defmacro assert-invoked ((method &rest args) &body body)
|
||||
"If during execution of the BODY the specified METHOD with ARGS
|
||||
hasn't been invoked, signals an ERROR."
|
||||
`(assert-invoked-impl (quote ,method) (list ,@args) (lambda () ,@body)))
|
||||
|
||||
(defun invoked (method &rest args)
|
||||
(signal 'invoked :method method :args args))
|
||||
|
||||
;;; The tests.
|
||||
|
||||
#|
|
||||
We will define a gray stream class, specialise
|
||||
the gray generic function methods on it and test that the methods
|
||||
are invoked when we call functions from common-lisp package
|
||||
on that stream.
|
||||
|
||||
Some of the gray generic functions are only invoked by default
|
||||
methods of other generic functions:
|
||||
|
||||
cl:format ~t or cl:pprint -> stream-advance-to-column -> stream-line-column
|
||||
stream-write-char
|
||||
cl:fresh-line -> stream-fresh-line -> stream-start-line-p -> stream-line-column
|
||||
stream-terpri
|
||||
|
||||
|
||||
If we define our methods for stream-advance-to-column and stream-fresh-line,
|
||||
then stream-start-line-p, stream-terpri, stram-line-column are not invoked.
|
||||
|
||||
Therefore we define another gray stream class. The first class is used
|
||||
for all lower level functions (stream-terpri). The second class
|
||||
is used to test methods for higher level functions (stream-fresh-line).
|
||||
|#
|
||||
|
||||
(defclass test-stream (fundamental-binary-input-stream
|
||||
fundamental-binary-output-stream
|
||||
fundamental-character-input-stream
|
||||
fundamental-character-output-stream)
|
||||
())
|
||||
|
||||
(defclass test-stream2 (test-stream) ())
|
||||
|
||||
(defmethod stream-read-char ((stream test-stream))
|
||||
(invoked 'stream-read-char stream))
|
||||
|
||||
(defmethod stream-unread-char ((stream test-stream) char)
|
||||
(invoked 'stream-unread-char stream char))
|
||||
|
||||
(defmethod stream-read-char-no-hang ((stream test-stream))
|
||||
(invoked 'stream-read-char-no-hang stream))
|
||||
|
||||
(defmethod stream-peek-char ((stream test-stream))
|
||||
(invoked 'stream-peek-char stream))
|
||||
|
||||
(defmethod stream-listen ((stream test-stream))
|
||||
(invoked 'stream-listen stream))
|
||||
|
||||
(defmethod stream-read-line ((stream test-stream))
|
||||
(invoked 'stream-read-line stream))
|
||||
|
||||
(defmethod stream-clear-input ((stream test-stream))
|
||||
(invoked 'stream-clear-input stream))
|
||||
|
||||
(defmethod stream-write-char ((stream test-stream) char)
|
||||
(invoked 'stream-write-char stream char))
|
||||
|
||||
(defmethod stream-line-column ((stream test-stream))
|
||||
(invoked 'stream-line-column stream))
|
||||
|
||||
(defmethod stream-start-line-p ((stream test-stream))
|
||||
(invoked 'stream-start-line-p stream))
|
||||
|
||||
(defmethod stream-write-string ((stream test-stream) string &optional start end)
|
||||
(invoked 'stream-write-string stream string start end))
|
||||
|
||||
(defmethod stream-terpri ((stream test-stream))
|
||||
(invoked 'stream-terpri stream))
|
||||
|
||||
(defmethod stream-fresh-line ((stream test-stream2))
|
||||
(invoked 'stream-fresh-line stream))
|
||||
|
||||
(defmethod stream-finish-output ((stream test-stream))
|
||||
(invoked 'stream-finish-output stream))
|
||||
|
||||
(defmethod stream-force-output ((stream test-stream))
|
||||
(invoked 'stream-force-output stream))
|
||||
|
||||
(defmethod stream-clear-output ((stream test-stream))
|
||||
(invoked 'stream-clear-output stream))
|
||||
|
||||
(defmethod stream-advance-to-column ((stream test-stream2) column)
|
||||
(invoked 'stream-advance-to-column stream column))
|
||||
|
||||
(defmethod stream-read-byte ((stream test-stream))
|
||||
(invoked 'stream-read-byte stream))
|
||||
|
||||
(defmethod stream-write-byte ((stream test-stream) byte)
|
||||
(invoked 'stream-write-byte stream byte))
|
||||
|
||||
(defmethod stream-read-sequence ((s test-stream) seq start end &key)
|
||||
(invoked 'stream-read-sequence s seq :start start :end end))
|
||||
|
||||
(defmethod stream-write-sequence ((s test-stream) seq start end &key)
|
||||
(invoked 'stream-write-sequence s seq :start start :end end))
|
||||
|
||||
(defmethod stream-file-position ((s test-stream))
|
||||
(invoked 'stream-file-position s))
|
||||
|
||||
(defmethod (setf stream-file-position) (newval (s test-stream))
|
||||
(invoked '(setf stream-file-position) newval s))
|
||||
|
||||
;; Convinience macro, used when we want to name
|
||||
;; the test case with the same name as of the gray streams method we test.
|
||||
(defmacro test-invoked ((method &rest args) &body body)
|
||||
`(test (,method)
|
||||
(assert-invoked (,method ,@args)
|
||||
,@body)))
|
||||
|
||||
(defun run-tests ()
|
||||
(let ((s (make-instance 'test-stream))
|
||||
(s2 (make-instance 'test-stream2)))
|
||||
(list
|
||||
(test-invoked (stream-read-char s)
|
||||
(read-char s))
|
||||
(test-invoked (stream-unread-char s #\a)
|
||||
(unread-char #\a s))
|
||||
(test-invoked (stream-read-char-no-hang s)
|
||||
(read-char-no-hang s))
|
||||
(test-invoked (stream-peek-char s)
|
||||
(peek-char nil s))
|
||||
(test-invoked (stream-listen s)
|
||||
(listen s))
|
||||
(test-invoked (stream-read-line s)
|
||||
(read-line s))
|
||||
(test-invoked (stream-clear-input s)
|
||||
(clear-input s))
|
||||
(test-invoked (stream-write-char s #\b)
|
||||
(write-char #\b s))
|
||||
(test-invoked (stream-line-column s)
|
||||
(format s "~10,t"))
|
||||
(test-invoked (stream-start-line-p s)
|
||||
(fresh-line s))
|
||||
(test-invoked (stream-write-string s "hello" 1 4)
|
||||
(write-string "hello" s :start 1 :end 4))
|
||||
(test-invoked (stream-terpri s)
|
||||
(fresh-line s))
|
||||
(test-invoked (stream-fresh-line s2)
|
||||
(fresh-line s2))
|
||||
(test-invoked (stream-finish-output s)
|
||||
(finish-output s))
|
||||
(test-invoked (stream-force-output s)
|
||||
(force-output s))
|
||||
(test-invoked (stream-clear-output s)
|
||||
(clear-output s))
|
||||
(test-invoked (stream-advance-to-column s2 10)
|
||||
(format s2 "~10,t"))
|
||||
(test-invoked (stream-read-byte s)
|
||||
(read-byte s))
|
||||
(test-invoked (stream-write-byte s 1)
|
||||
(write-byte 1 s))
|
||||
;;; extensions
|
||||
(let ((seq (vector 1 2)))
|
||||
(test-invoked (stream-read-sequence s seq :start 0 :end 1)
|
||||
(read-sequence seq s :start 0 :end 1))
|
||||
(test-invoked (stream-write-sequence s seq :start 0 :end 1)
|
||||
(write-sequence seq s :start 0 :end 1)))
|
||||
(test-invoked (stream-file-position s)
|
||||
(file-position s))
|
||||
(test (setf-stream-file-position)
|
||||
(assert-invoked ((setf stream-file-position) 9 s)
|
||||
(file-position s 9))))))
|
||||
|
||||
(defun failed-tests (results)
|
||||
(remove-if-not #'failed-p results))
|
||||
|
||||
(defun failed-test-names (results)
|
||||
(mapcar (lambda (result)
|
||||
(string-downcase (name result)))
|
||||
(failed-tests results)))
|
||||
|
||||
#|
|
||||
(failed-test-names (run-tests))
|
||||
|
||||
(setf *allow-debugger* nil))
|
||||
|
||||
|#
|
||||
Loading…
Add table
Add a link
Reference in a new issue