Commit ea624e40 authored by Tobias C. Rittweiler's avatar Tobias C. Rittweiler

Add test suite.

darcs-hash:20090925192253-f5546-4cfa20921b7be33cf7a415fbb463ecbea3334c47.gz
parent 7ef8cd59
......@@ -4,6 +4,13 @@
(defclass asdf::named-readtables-source-file (asdf:cl-source-file) ())
#+sbcl
(defmethod asdf:perform :around ((o asdf:compile-op)
(c asdf::named-readtables-source-file))
(let ((sb-ext:*derive-function-types* t))
(call-next-method)))
(asdf:defsystem :named-readtables
:description "Library that creates a namespace for named readtable akin to the namespace of packages."
:author "Tobias C. Rittweiler <trittweiler@common-lisp.net>"
......@@ -16,9 +23,27 @@
(:file "cruft" :depends-on ("package" "utils"))
(:file "named-readtables" :depends-on ("package" "utils" "cruft"))))
(defmethod asdf:perform ((o asdf:test-op)
(c (eql (asdf:find-system :named-readtables))))
(asdf:operate 'asdf:load-op :named-readtables-test)
(asdf:operate 'asdf:test-op :named-readtables-test))
#+sbcl
(defmethod asdf:perform :around
((operation asdf:compile-op) (component asdf::named-readtables-source-file))
(let ((sb-ext:*derive-function-types* t))
(call-next-method)))
\ No newline at end of file
(asdf:defsystem :named-readtables-test
:description "Test suite for Named-Readtables library."
:author "Tobias C. Rittweiler <trittweiler@common-lisp.net>"
:depends-on (:named-readtables)
:components
((:module tests
:default-component-class asdf::named-readtables-source-file
:serial t
:components
((:file "package")
(:file "rt" :depends-on ("package"))
(:file "tests" :depends-on ("package" "rt"))))))
(defmethod asdf:perform ((o asdf:test-op)
(c (eql (asdf:find-system
:named-readtables-test))))
(let ((*package* (find-package :named-readtables-test)))
(funcall (intern (string '#:do-tests) *package*))))
\ No newline at end of file
;;; -*- Mode:Lisp -*-
(in-package :cl-user)
(defpackage :named-readtables-test
(:use :cl :named-readtables)
(:import-from :named-readtables
#:*empty-readtable*
#:do-readtable
#:ensure-function
#:function=))
\ No newline at end of file
#|----------------------------------------------------------------------------|
| Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
| |
| Permission to use, copy, modify, and distribute this software and its |
| documentation for any purpose and without fee is hereby granted, provided |
| that this copyright and permission notice appear in all copies and |
| supporting documentation, and that the name of M.I.T. not be used in |
| advertising or publicity pertaining to distribution of the software |
| without specific, written prior permission. M.I.T. makes no |
| representations about the suitability of this software for any purpose. |
| It is provided "as is" without express or implied warranty. |
| |
| M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
| ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
| M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
| ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
| WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
| ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
| SOFTWARE. |
|----------------------------------------------------------------------------|#
;; (defpackage :rt
;; (:use #:cl)
;; (:export #:*do-tests-when-defined* #:*test* #:continue-testing
;; #:deftest #:do-test #:do-tests #:get-test #:pending-tests
;; #:rem-all-tests #:rem-test)
;; (:documentation "The MIT regression tester"))
;; (in-package :rt)
(in-package :named-readtables-test)
(defvar *test* nil "Current test name")
(defvar *do-tests-when-defined* nil)
(defvar *entries* '(nil) "Test database")
(defvar *in-test* nil "Used by TEST")
(defvar *debug* nil "For debugging")
(defvar *catch-errors* t
"When true, causes errors in a test to be caught.")
(defvar *print-circle-on-failure* nil
"Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
(defvar *compile-tests* nil
"When true, compile the tests before running them.")
(defvar *optimization-settings* '((safety 3)))
(defvar *expected-failures* nil
"A list of test names that are expected to fail.")
(defstruct (entry (:conc-name nil)
(:type list))
pend name form)
(defmacro vals (entry) `(cdddr ,entry))
(defmacro defn (entry) `(cdr ,entry))
(defun pending-tests ()
(do ((l (cdr *entries*) (cdr l))
(r nil))
((null l) (nreverse r))
(when (pend (car l))
(push (name (car l)) r))))
(defun rem-all-tests ()
(setq *entries* (list nil))
nil)
(defun rem-test (&optional (name *test*))
(do ((l *entries* (cdr l)))
((null (cdr l)) nil)
(when (equal (name (cadr l)) name)
(setf (cdr l) (cddr l))
(return name))))
(defun get-test (&optional (name *test*))
(defn (get-entry name)))
(defun get-entry (name)
(let ((entry (find name (cdr *entries*)
:key #'name
:test #'equal)))
(when (null entry)
(report-error t
"~%No test with name ~:@(~S~)."
name))
entry))
(defmacro deftest (name form &rest values)
`(add-entry '(t ,name ,form .,values)))
(defun add-entry (entry)
(setq entry (copy-list entry))
(do ((l *entries* (cdr l))) (nil)
(when (null (cdr l))
(setf (cdr l) (list entry))
(return nil))
(when (equal (name (cadr l))
(name entry))
(setf (cadr l) entry)
(report-error nil
"Redefining test ~:@(~S~)"
(name entry))
(return nil)))
(when *do-tests-when-defined*
(do-entry entry))
(setq *test* (name entry)))
(defun report-error (error? &rest args)
(cond (*debug*
(apply #'format t args)
(if error? (throw '*debug* nil)))
(error? (apply #'error args))
(t (apply #'warn args))))
(defun do-test (&optional (name *test*))
(do-entry (get-entry name)))
(defun equalp-with-case (x y)
"Like EQUALP, but doesn't do case conversion of characters."
(cond
((eq x y) t)
((consp x)
(and (consp y)
(equalp-with-case (car x) (car y))
(equalp-with-case (cdr x) (cdr y))))
((and (typep x 'array)
(= (array-rank x) 0))
(equalp-with-case (aref x) (aref y)))
((typep x 'vector)
(and (typep y 'vector)
(let ((x-len (length x))
(y-len (length y)))
(and (eql x-len y-len)
(loop
for e1 across x
for e2 across y
always (equalp-with-case e1 e2))))))
((and (typep x 'array)
(typep y 'array)
(not (equal (array-dimensions x)
(array-dimensions y))))
nil)
((typep x 'array)
(and (typep y 'array)
(let ((size (array-total-size x)))
(loop for i from 0 below size
always (equalp-with-case (row-major-aref x i)
(row-major-aref y i))))))
(t (eql x y))))
(defun do-entry (entry &optional
(s *standard-output*))
(catch '*in-test*
(setq *test* (name entry))
(setf (pend entry) t)
(let* ((*in-test* t)
;; (*break-on-warnings* t)
(aborted nil)
r)
;; (declare (special *break-on-warnings*))
(block aborted
(setf r
(flet ((%do
()
(if *compile-tests*
(multiple-value-list
(funcall (compile
nil
`(lambda ()
(declare
(optimize ,@*optimization-settings*))
,(form entry)))))
(multiple-value-list
(eval (form entry))))))
(if *catch-errors*
(handler-bind
((style-warning #'muffle-warning)
(error #'(lambda (c)
(setf aborted t)
(setf r (list c))
(return-from aborted nil))))
(%do))
(%do)))))
(setf (pend entry)
(or aborted
(not (equalp-with-case r (vals entry)))))
(when (pend entry)
(let ((*print-circle* *print-circle-on-failure*))
(format s "~&Test ~:@(~S~) failed~
~%Form: ~S~
~%Expected value~P: ~
~{~S~^~%~17t~}~%"
*test* (form entry)
(length (vals entry))
(vals entry))
(format s "Actual value~P: ~
~{~S~^~%~15t~}.~%"
(length r) r)))))
(when (not (pend entry)) *test*))
(defun continue-testing ()
(if *in-test*
(throw '*in-test* nil)
(do-entries *standard-output*)))
(defun do-tests (&optional
(out *standard-output*))
(dolist (entry (cdr *entries*))
(setf (pend entry) t))
(if (streamp out)
(do-entries out)
(with-open-file
(stream out :direction :output)
(do-entries stream))))
(defun do-entries (s)
(format s "~&Doing ~A pending test~:P ~
of ~A tests total.~%"
(count t (cdr *entries*)
:key #'pend)
(length (cdr *entries*)))
(dolist (entry (cdr *entries*))
(when (pend entry)
(format s "~@[~<~%~:; ~:@(~S~)~>~]"
(do-entry entry s))))
(let ((pending (pending-tests))
(expected-table (make-hash-table :test #'equal)))
(dolist (ex *expected-failures*)
(setf (gethash ex expected-table) t))
(let ((new-failures
(loop for pend in pending
unless (gethash pend expected-table)
collect pend)))
(if (null pending)
(format s "~&No tests failed.")
(progn
(format s "~&~A out of ~A ~
total tests failed: ~
~:@(~{~<~% ~1:;~S~>~
~^, ~}~)."
(length pending)
(length (cdr *entries*))
pending)
(if (null new-failures)
(format s "~&No unexpected failures.")
(when *expected-failures*
(format s "~&~A unexpected failures: ~
~:@(~{~<~% ~1:;~S~>~
~^, ~}~)."
(length new-failures)
new-failures)))
))
(finish-output s)
(null pending))))
;;; -*- Mode:Lisp -*-
(in-package :named-readtables-test)
(defun map-alist (car-fn cdr-fn alist)
(mapcar #'(lambda (entry)
(cons (funcall car-fn (car entry))
(funcall cdr-fn (cdr entry))))
alist))
(defmacro signals-error-p (name &body body)
`(handler-case (prog1 nil ,@body)
(,(second name) () t)))
(defmacro continue-condition (name &body body)
`(handler-bind ((,(second name) #'continue))
,@body))
(defun read-with-readtable (name string)
(let ((*package* '#.*package*)
(*readtable* (find-readtable name)))
(values (read-from-string string))))
(defun empty-readtable ()
(copy-readtable *empty-readtable*))
(defun random-named-readtable ()
(let ((readtables (list-all-named-readtables)))
(nth (random (length readtables)) readtables)))
(defun readtable-content (named-readtable-designator)
(let ((readtable (ensure-readtable named-readtable-designator))
(result '()))
;; Make sure to canonicalize the order and function designators so
;; we can compare easily.
(do-readtable ((char reader-fn ntp disp? table) readtable)
(setq table (sort (copy-list table) #'char< :key #'car))
(push (list* char
(ensure-function reader-fn)
ntp
(and disp? (list (map-alist #'identity
#'ensure-function
table))))
result))
(sort result #'char< :key #'car)))
(defun readtable= (rt1 rt2)
(tree-equal (readtable-content rt1) (readtable-content rt2)
:test #'(lambda (x y)
(if (and (functionp x) (functionp y))
(function= x y)
(eql x y)))))
(defun read-A (stream c)
(declare (ignore stream c))
:a)
(defun read-A-as-X (stream c)
(declare (ignore stream c))
:x)
(defun read-B (stream c)
(declare (ignore stream c))
:b)
(defun read-sharp-paren (stream c n)
(declare (ignore stream c n))
'sharp-paren)
(defun read-C (stream c)
(declare (ignore stream c))
:c)
(defreadtable A
(:macro-char #\A #'read-A))
(defreadtable A-as-X
(:macro-char #\A #'read-A-as-X))
(defreadtable B
(:macro-char #\B #'read-B))
(defreadtable C
(:macro-char #\C #'read-C))
(defreadtable A+B+C
(:merge A B C))
(defreadtable standard+A+B+C
(:merge :standard A+B+C))
(defreadtable sharp-paren
(:macro-char #\# :dispatch)
(:dispatch-macro-char #\# #\( #'read-sharp-paren))
(deftest cruft.1
(function= (get-macro-character #\" (copy-readtable nil))
(get-macro-character #\" (copy-readtable nil)))
t)
(deftest standard.1
(read-with-readtable :standard "ABC")
ABC)
(deftest standard.2
(read-with-readtable :standard "(A B C)")
(A B C))
(deftest standard.3
(let ((x (find-readtable nil))
(y (find-readtable :standard))
(z (find-readtable :common-lisp)))
(and (eq x y) (eq y z)))
t)
(deftest modern.1
(read-with-readtable :modern "FooF")
|FooF|)
(deftest empty.1
(null (readtable-content (empty-readtable)))
t)
(deftest empty.2
(let ((rt (copy-readtable (find-readtable :standard))))
(readtable= (merge-readtables-into (empty-readtable) rt)
(merge-readtables-into rt (empty-readtable))))
t)
(deftest basics.1
(read-with-readtable 'A "A")
:a)
(deftest basics.2
(read-with-readtable 'A-as-X "A")
:x)
(deftest basics.3
(read-with-readtable 'A "B")
B)
(deftest basics.4
(read-with-readtable 'A "(A B C)")
|(|)
(deftest unregister.1
(let ((rt (find-readtable 'A)))
(register-readtable 'does-not-exist rt)
(values
(and (find-readtable 'does-not-exist) t)
(unregister-readtable 'does-not-exist)
(and (find-readtable 'does-not-exist) t)))
t t nil)
(deftest name.1
(let ((rt (random-named-readtable)))
(eq rt (find-readtable (readtable-name rt))))
t)
(deftest ensure.1
(unwind-protect
(let* ((x (ensure-readtable 'does-not-exist (find-readtable 'A)))
(y (find-readtable 'A))
(z (find-readtable 'does-not-exist)))
(and (eq x y) (eq y z)))
(unregister-readtable 'does-not-exist))
t)
(deftest merge.1
(values
(read-with-readtable 'A+B+C "A")
(read-with-readtable 'A+B+C "B")
(read-with-readtable 'A+B+C "C"))
:a :b :c)
(deftest merge.2
(read-with-readtable 'standard+A+B+C "(A B C)")
(:a :b :c))
(deftest merge.3
(read-with-readtable 'standard+A+B+C "#(A B C)")
#(:a :b :c))
(deftest merge.4
(let ((A+B+C+standard (merge-readtables-into (copy-named-readtable 'A+B+C)
:standard)))
(readtable= 'standard+A+B+C A+B+C+standard))
t)
(deftest rename.1
(unwind-protect
(progn (make-readtable 'A* :merge '(A))
(rename-readtable 'A* 'A**)
(values (and (find-readtable 'A*) t)
(and (find-readtable 'A**) t)))
(unregister-readtable 'A*)
(unregister-readtable 'A**))
nil
t)
(deftest reader-macro-conflict.1
(signals-error-p 'reader-macro-conflict
(merge-readtables-into (empty-readtable) 'A 'A-as-X))
t)
(deftest reader-macro-conflict.2
(signals-error-p 'reader-macro-conflict
(merge-readtables-into (empty-readtable) :standard :standard))
nil)
(deftest reader-macro-conflict.3
(signals-error-p 'reader-macro-conflict
(merge-readtables-into (empty-readtable) 'A+B+C 'A))
nil)
(deftest reader-macro-conflict.4
(signals-error-p 'reader-macro-conflict
(merge-readtables-into (empty-readtable) :standard 'sharp-paren))
t)
(deftest readtable-does-not-exist.1
(signals-error-p 'readtable-does-not-exist
(ensure-readtable 'does-not-exist))
t)
(deftest readtable-does-already-exist.1
(signals-error-p 'readtable-does-already-exist
(make-readtable 'A))
t)
(deftest readtable-does-already-exist.2
(signals-error-p 'readtable-does-already-exist
(make-readtable 'A))
t)
(deftest readtable-does-already-exist.3
(let ((rt (make-readtable 'does-not-exist :merge '(:standard A B))))
(declare (ignore rt))
(unwind-protect
(read-with-readtable (continue-condition 'readtable-does-already-exist
(make-readtable 'does-not-exist
:merge '(:standard A C)))
"(A B C)")
(unregister-readtable 'does-not-exist)))
(:a B :c))
\ No newline at end of file
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment