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