Commit 43ca9233 authored by pfdietz's avatar pfdietz
Browse files

Finished adding the class precedence list tests. Added a new test option that...

Finished adding the class precedence list tests.  Added a new test option that tries to do more of the eval manually, to reduce compiler optimizations that something like sbcl's evaluator might perform.
parent aa5075ae
......@@ -13,16 +13,28 @@
collect
`(:method list ((x ,s)) ',s))))
(defmacro def-cpl-test (objform expected-cpl)
`(deftest ,(intern (concatenate 'string
(symbol-name (first expected-cpl))
"-CPL")
:cl-test)
(let* ((obj ,objform)
(cpl (class-precedence-list obj)))
(and (eql (first cpl) ',(first expected-cpl))
(is-noncontiguous-sublist-of cpl ',expected-cpl)))
t))
(defmacro def-cpl-test (objform expected-cpl &optional name)
(let* ((ordered (loop for e = expected-cpl then (cdr e)
for x = (car e)
for y = (cadr e)
while y
always (subtypep x y))))
`(deftest ,(or name
(intern (concatenate 'string
(symbol-name (first expected-cpl))
"-CPL")
:cl-test))
(let* ((obj ,objform)
(cpl (class-precedence-list obj)))
(or ,(if ordered
nil
`(and (not (eql (class-of obj) (find-class ',(first expected-cpl))))
(progn (format t "~%Note: ~S not an instance of ~A~%"
',objform ',(first expected-cpl))
t)))
(and (eql (first cpl) ',(first expected-cpl))
(is-noncontiguous-sublist-of cpl ',expected-cpl))))
t)))
;;; Condition types
......@@ -35,6 +47,7 @@
(def-cond-cpl-test (control-error error serious-condition condition t))
(def-cond-cpl-test (division-by-zero arithmetic-error error
serious-condition condition t))
(def-cond-cpl-test (end-of-file stream-error error serious-condition condition t))
(def-cond-cpl-test (error serious-condition condition t))
(def-cond-cpl-test (file-error error serious-condition condition t))
(def-cond-cpl-test (floating-point-inexact arithmetic-error error
......@@ -71,10 +84,88 @@
(def-cpl-test (make-array '(10) :element-type 'bit :adjustable t :fill-pointer 5)
(bit-vector vector array sequence t))
(def-cpl-test (make-broadcast-stream) (broadcast-stream stream t))
(when (typep (class-of 'symbol) 'built-in-class)
(def-cpl-test (class-of 'symbol) (built-in-class class standard-object t)))
(def-cpl-test (class-of 'symbol) (built-in-class class standard-object t))
(def-cpl-test #\a (character t) character-cpl.1)
(def-cpl-test #c(1.0 2.0) (complex number t) complex-cpl.1)
(def-cpl-test #c(1 2) (complex number t) complex-cpl.2)
(def-cpl-test #c(1/2 2/3) (complex number t) complex-cpl.3)
(def-cpl-test (make-concatenated-stream) (concatenated-stream stream t))
(def-cpl-test '(a b c) (cons list sequence t))
(def-cpl-test (let ((out (make-string-output-stream)))
(make-echo-stream (make-string-input-stream "foo") out))
(echo-stream stream t))
(def-cpl-test (open "class-precedence-lists.lsp" :direction :probe)
(file-stream stream t))
(def-cpl-test 1.0s0 (float real number t) float-cpl.1)
(def-cpl-test 1.0f0 (float real number t) float-cpl.2)
(def-cpl-test 1.0d0 (float real number t) float-cpl.3)
(def-cpl-test 1.0l0 (float real number t) float-cpl.4)
(def-cpl-test #'car (function t))
(def-cpl-test #'make-instance (generic-function function t))
(def-cpl-test (make-hash-table) (hash-table t) hash-table-cpl.1)
(def-cpl-test (make-hash-table :test 'eq) (hash-table t) hash-table-cpl.2)
(def-cpl-test (make-hash-table :test 'equal) (hash-table t) hash-table-cpl.3)
(def-cpl-test 0 (integer rational real number t) integer-cpl.1)
(def-cpl-test (1+ most-positive-fixnum) (integer rational real number t) integer-cpl.2)
(def-cpl-test (1- most-negative-fixnum) (integer rational real number t) integer-cpl.3)
(def-cpl-test nil (list sequence t) list-cpl.1)
(def-cpl-test '(a b c) (list sequence t) list-cpl.2)
;;; Insert a test for LOGICAL-PATHNAME here
;;; (def-cpl-test ????? (logical-pathname pathname t))
(def-cpl-test (find-method #'class-name nil (list (find-class t))) (method t))
;;; Insert test for METHOD-COMBINATION here
(def-cpl-test nil (null symbol list sequence t))
(def-cpl-test (find-package "CL") (package t))
(def-cpl-test #p"foo" (pathname t))
(def-cpl-test *random-state* (random-state t))
(def-cpl-test 5/3 (ratio rational real number t))
(def-cpl-test *readtable* (readtable t))
(defclass cpl-example-class () ())
(def-cpl-test (find-class 'cpl-example-class)
(standard-class class standard-object t))
(defgeneric cpl-example-gf (x y))
(def-cpl-test #'cpl-example-gf (standard-generic-function generic-function function t))
(def-cpl-test (eval '(defmethod cpl-example-gf ((x t) (y t)) (list y x)))
(standard-method method standard-object t))
(def-cpl-test (make-array '(10) :element-type 'character :initial-element #\a
:fill-pointer t :adjustable t)
(string vector array sequence t) string-cpl.1)
(def-cpl-test "abcd" (string vector array sequence t) string-cpl.2)
(def-cpl-test (make-string-input-stream "abcdef") (string-stream stream t))
(defstruct cpl-example-structure-class a b c)
;;; No test for STRUCTURE-OBJECT
(def-cpl-test 'a (symbol t))
(defparameter *cpl-input-stream* (make-string-input-stream "foofoofoofoo"))
(def-cpl-test (make-synonym-stream '*cpl-input-stream*) (synonym-stream stream t))
(defparameter *cpl-output-stream* (make-string-output-stream))
(def-cpl-test (make-two-way-stream *cpl-input-stream* *cpl-output-stream*)
(two-way-stream stream t))
(def-cpl-test (make-array '(10) :fill-pointer t :adjustable t :initial-element '(a b c))
(vector array sequence t))
......@@ -16,5 +16,4 @@
(load "deftype.lsp")
(load "standard-generic-function.lsp")
(load "type-of.lsp")
(load "class-precedence-lists.lsp")
......@@ -34,8 +34,8 @@
(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 *compile-tests* nil "When true, compile the tests before running them.")
(defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.")
(defvar *optimization-settings* '((safety 3)))
(defvar *expected-failures* nil
......@@ -170,16 +170,21 @@ them.")
(setf r
(flet ((%do
()
(if *compile-tests*
(multiple-value-list
(funcall (compile
nil
`(lambda ()
(declare
(optimize ,@*optimization-settings*))
,(form entry)))))
(cond
(*compile-tests*
(multiple-value-list
(eval (form entry))))))
(funcall (compile
nil
`(lambda ()
(declare
(optimize ,@*optimization-settings*))
,(form entry))))))
(*expanded-eval*
(multiple-value-list
(expanded-eval (form entry))))
(t
(multiple-value-list
(eval (form entry)))))))
(if *catch-errors*
(handler-bind
(#-ecl (style-warning #'muffle-warning)
......@@ -208,6 +213,40 @@ them.")
(length r) r)))))
(when (not (pend entry)) *test*))
(defun expanded-eval (form)
"Split off top level of a form and eval separately. This reduces the chance that
compiler optimizations will fold away runtime computation."
(if (not (consp form))
(eval form)
(let ((op (car form)))
(cond
((eq op 'let)
(let* ((bindings (loop for b in (cadr form)
collect (if (consp b) b (list b nil))))
(vars (mapcar #'car bindings))
(binding-forms (mapcar #'cadr bindings)))
(apply
(eval `(lambda ,vars ,@(cddr form)))
(mapcar #'eval binding-forms))))
((and (eq op 'let*) (cadr form))
(let* ((bindings (loop for b in (cadr form)
collect (if (consp b) b (list b nil))))
(vars (mapcar #'car bindings))
(binding-forms (mapcar #'cadr bindings)))
(funcall
(eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form)))
(eval (car binding-forms)))))
((eq op 'progn)
(loop for e on (cdr form)
do (if (null (cdr e)) (return (eval (car e)))
(eval (car e)))))
((and (symbolp op) (fboundp op)
(not (macro-function op))
(not (special-operator-p op)))
(apply (symbol-function op)
(mapcar #'eval (cdr form))))
(t (eval form))))))
(defun continue-testing ()
(if *in-test*
(throw '*in-test* nil)
......
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