Skip to content
Snippets Groups Projects
Commit 2b8e2331 authored by pfdietz's avatar pfdietz
Browse files

Added more class tests, fixed up a lambda-list-keywords test.

parent a31821cd
No related branches found
No related tags found
No related merge requests found
......@@ -1430,3 +1430,9 @@ the condition to go uncaught if it cannot be classified."
(unsigned-byte 32) float short-float
single-float double-float long-float
nil character base-char symbol boolean null))
(defun collect-properties (plist prop)
"Collect all the properties in plist for a property prop."
(loop for e on plist by #'cddr
when (eql (car e) prop)
collect (cadr e)))
......@@ -9,11 +9,15 @@
(intern (apply #'concatenate 'string (mapcar #'string args))
(find-package :cl-test)))
(defparameter *defclass-slot-readers* nil)
(defparameter *defclass-slot-writers* nil)
(defparameter *defclass-slot-accessors* nil)
(defmacro defclass-with-tests
(&whole args
class-name superclasses slot-specifiers
&rest class-options)
(assert (typep class-name '(and (not null) symbol)))
(assert (listp superclasses))
(assert (every #'(lambda (x) (typep x '(and (not null) symbol)))
......@@ -30,17 +34,63 @@
class-options))
(assert (eql (length class-options)
(length (remove-duplicates class-options))))
(let* ((default-initargs (second (assoc :default-initargs class-options)))
(metaclass (or (second (assoc :metaclass class-options))
'standard-class))
(doc (second (assoc :documentation class-options)))
(slot-names
(loop for slot-spec in slot-specifiers
collect (cond
((symbolp slot-spec) slot-spec)
(t (assert (consp slot-spec))
(assert (symbolp (car slot-spec)))
(car slot-spec)))))
(slot-options
(loop for slot-spec in slot-specifiers
collect (if (consp slot-spec)
(cdr slot-spec)
nil)))
(readers
(loop for slot-option in slot-options
append (collect-properties slot-option :reader)))
(writers
(loop for slot-option in slot-options
append (collect-properties slot-option :writer)))
(accessors
(loop for slot-option in slot-options
append (collect-properties slot-option :accessor)))
(allocations
(loop for slot-option in slot-options
collect (or (get :allocation slot-option)
:instance)))
(initargs
(loop for slot-option in slot-options
collect (collect-properties slot-option :initarg)))
(types
(loop for slot-option in slot-options
collect (collect-properties slot-option :type)))
(initforms
(loop for slot-option in slot-options
collect (collect-properties slot-option :initform)))
)
(declare (ignorable readers writers accessors allocations
initargs types initforms default-initargs
doc))
(assert (loop for e in types always (< (length e) 2)))
(assert (loop for e in initforms always (< (length e) 2)))
(setf *defclass-slot-readers* (append readers *defclass-slot-readers*))
(setf *defclass-slot-writers* (append writers *defclass-slot-writers*))
(setf *defclass-slot-accessors*
(append accessors *defclass-slot-accessors*))
`(progn
(eval-when (load eval compile)
(ignore-errors (defclass ,@args)))
(ignore-errors (defclass ,@(cdr args))))
(deftest ,(make-defclass-test-name class-name
"-IS-IN-ITS-METACLASS")
......@@ -50,15 +100,45 @@
,@(when (eq metaclass 'standard-class)
`((deftest ,(make-defclass-test-name class-name
"S-ARE-STANDARD-OBJECTS")
(subtypep* ,class-name 'standard-object)
(subtypep* ',class-name 'standard-object)
t t)))
;;; More tests here
,@(loop for slot-name in slot-names
collect
`(deftest ,(make-defclass-test-name class-name
"-HAS-SLOT-NAMED-"
slot-name)
(notnot-mv (slot-exists-p (make-instance ',class-name)
',slot-name))
t))
(deftest ,(make-defclass-test-name class-name
"-INSTANCES-CLASS-IS-THIS-ONE")
(let ((class (find-class ',class-name)))
(eqlt (class-of (allocate-instance class)) class))
t)
)))
\ No newline at end of file
(defmacro generate-slot-tests ()
"Generate generic tests from the read/writer/accessor functions
for slots from defclass-with-tests."
(let ((funs (remove-duplicates
(append *defclass-slot-readers*
*defclass-slot-writers*
*defclass-slot-accessors*))))
`(progn
(deftest class-readers/writers/accessors-are-generic-functions
(loop for sym in ',funs
unless (typep (symbol-function sym) 'generic-function)
collect sym)
nil)
(deftest class-accessors-have-generic-setf-functions
(append
,@(loop for sym in *defclass-slot-accessors*
collect
`(and (not (typep (function (setf ,sym))
'generic-function))
'(,sym))))
nil))))
......@@ -65,9 +65,16 @@
program-error)
;;; Now non-error tests
(defclass-with-tests defclass-1 nil nil)
(defclass-with-tests defclass-2 nil (slot1 slot2 slot3))
;;; At end, generate slot tests
(generate-slot-tests) ;; a macro
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Thu Mar 27 21:29:53 2003
;;;; Contains: Tests for ENSURE-GENERIC-FUNCTION
(in-package :cl-test)
(deftest ensure-generic-function.1
(subtypep* (classify-error (ensure-generic-function 'car)) 'error)
t t)
(deftest ensure-generic-function.2
(subtypep* (classify-error (ensure-generic-function 'defclass)) 'error)
t t)
(deftest ensure-generic-function.3
(subtypep* (classify-error (ensure-generic-function 'tagbody)) 'error)
t t)
(deftest ensure-generic-function.4
(let ((f 'egf-fun-4))
(when (fboundp f) (fmakunbound f))
(values
(fboundp f)
(notnot-mv (typep (ensure-generic-function f) 'generic-function))
(notnot-mv (typep (ensure-generic-function f) 'generic-function))
(notnot-mv (typep (symbol-function f) 'generic-function))))
nil t t t)
(deftest ensure-generic-function.5
(let ((f 'egf-fun-5))
(when (fboundp f) (fmakunbound f))
(values
(fboundp f)
(notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c))
'generic-function))
;; Test of incongruent generic function lambda list when no
;; methods exist
(notnot-mv (typep (ensure-generic-function f :lambda-list '(x y))
'generic-function))
(notnot-mv (typep (symbol-function f) 'generic-function))))
nil t t t)
(deftest ensure-generic-function.6
(let ((f 'egf-fun-6))
(when (fboundp f) (fmakunbound f))
(values
(fboundp f)
(notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c))
'generic-function))
(notnot-mv (eval `(defmethod ,f ((a t)(b t)(c t)) (list a b c))))
;; Test of incongruent generic function lambda list when no
;; methods exist
(subtypep*
(classify-error** `(ensure-generic-function ',f :lambda-list '(x y)))
'error)))
nil t t t)
......@@ -25,15 +25,16 @@
t)
;;; No lambda list keywords are in the keyword package
(deftest lambda-list-keywords.4
(some #'keywordp lambda-list-keywords)
nil)
;;; (deftest lambda-list-keywords.4
;;; (some #'keywordp lambda-list-keywords)
;;; nil)
;;; Every keyword starts with an ampersand
(deftest lambda-list-keywords.5
(notevery #'(lambda (sym)
(let ((name (symbol-name sym)))
(and (> (length name) 0)
(eql (aref name 0) #\&))))
(and (symbolp sym)
(let ((name (symbol-name sym)))
(and (> (length name) 0)
(eql (aref name 0) #\&)))))
lambda-list-keywords)
nil)
......@@ -5,4 +5,6 @@
(compile-and-load "defclass-aux.lsp")
(load "defclass.lsp")
(load "ensure-generic-function.lsp")
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment