From 2b8e23317f3922196ab5e09cf4367aa9f68c5dfb Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Sat, 29 Mar 2003 03:55:28 +0000 Subject: [PATCH] Added more class tests, fixed up a lambda-list-keywords test. --- ansi-tests/ansi-aux.lsp | 6 ++ ansi-tests/defclass-aux.lsp | 104 ++++++++++++++++++++++--- ansi-tests/defclass.lsp | 7 ++ ansi-tests/ensure-generic-function.lsp | 60 ++++++++++++++ ansi-tests/lambda-list-keywords.lsp | 13 ++-- ansi-tests/load-objects.lsp | 2 + 6 files changed, 174 insertions(+), 18 deletions(-) create mode 100644 ansi-tests/ensure-generic-function.lsp diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index c5e2c582..3e66ab6d 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -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))) diff --git a/ansi-tests/defclass-aux.lsp b/ansi-tests/defclass-aux.lsp index 5aba3230..a92105f4 100644 --- a/ansi-tests/defclass-aux.lsp +++ b/ansi-tests/defclass-aux.lsp @@ -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)))) diff --git a/ansi-tests/defclass.lsp b/ansi-tests/defclass.lsp index a020c363..a7036cf2 100644 --- a/ansi-tests/defclass.lsp +++ b/ansi-tests/defclass.lsp @@ -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 + diff --git a/ansi-tests/ensure-generic-function.lsp b/ansi-tests/ensure-generic-function.lsp new file mode 100644 index 00000000..a0ae2d38 --- /dev/null +++ b/ansi-tests/ensure-generic-function.lsp @@ -0,0 +1,60 @@ +;-*- 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) + + + diff --git a/ansi-tests/lambda-list-keywords.lsp b/ansi-tests/lambda-list-keywords.lsp index 856727da..a19ed3ef 100644 --- a/ansi-tests/lambda-list-keywords.lsp +++ b/ansi-tests/lambda-list-keywords.lsp @@ -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) diff --git a/ansi-tests/load-objects.lsp b/ansi-tests/load-objects.lsp index 4c4c128b..ed302966 100644 --- a/ansi-tests/load-objects.lsp +++ b/ansi-tests/load-objects.lsp @@ -5,4 +5,6 @@ (compile-and-load "defclass-aux.lsp") (load "defclass.lsp") +(load "ensure-generic-function.lsp") + -- GitLab