Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
ansi-test
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Operations
Operations
Incidents
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
Karsten Poeck
ansi-test
Commits
2b8e2331
Commit
2b8e2331
authored
Mar 29, 2003
by
pfdietz
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Added more class tests, fixed up a lambda-list-keywords test.
parent
a31821cd
Changes
6
Hide whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
174 additions
and
18 deletions
+174
-18
ansi-tests/ansi-aux.lsp
ansi-tests/ansi-aux.lsp
+6
-0
ansi-tests/defclass-aux.lsp
ansi-tests/defclass-aux.lsp
+92
-12
ansi-tests/defclass.lsp
ansi-tests/defclass.lsp
+7
-0
ansi-tests/ensure-generic-function.lsp
ansi-tests/ensure-generic-function.lsp
+60
-0
ansi-tests/lambda-list-keywords.lsp
ansi-tests/lambda-list-keywords.lsp
+7
-6
ansi-tests/load-objects.lsp
ansi-tests/load-objects.lsp
+2
-0
No files found.
ansi-tests/ansi-aux.lsp
View file @
2b8e2331
...
@@ -1430,3 +1430,9 @@ the condition to go uncaught if it cannot be classified."
...
@@ -1430,3 +1430,9 @@ the condition to go uncaught if it cannot be classified."
(unsigned-byte 32) float short-float
(unsigned-byte 32) float short-float
single-float double-float long-float
single-float double-float long-float
nil character base-char symbol boolean null))
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)))
ansi-tests/defclass-aux.lsp
View file @
2b8e2331
...
@@ -9,11 +9,15 @@
...
@@ -9,11 +9,15 @@
(intern (apply #'concatenate 'string (mapcar #'string args))
(intern (apply #'concatenate 'string (mapcar #'string args))
(find-package :cl-test)))
(find-package :cl-test)))
(defparameter *defclass-slot-readers* nil)
(defparameter *defclass-slot-writers* nil)
(defparameter *defclass-slot-accessors* nil)
(defmacro defclass-with-tests
(defmacro defclass-with-tests
(&whole args
(&whole args
class-name superclasses slot-specifiers
class-name superclasses slot-specifiers
&rest class-options)
&rest class-options)
(assert (typep class-name '(and (not null) symbol)))
(assert (typep class-name '(and (not null) symbol)))
(assert (listp superclasses))
(assert (listp superclasses))
(assert (every #'(lambda (x) (typep x '(and (not null) symbol)))
(assert (every #'(lambda (x) (typep x '(and (not null) symbol)))
...
@@ -30,17 +34,63 @@
...
@@ -30,17 +34,63 @@
class-options))
class-options))
(assert (eql (length class-options)
(assert (eql (length class-options)
(length (remove-duplicates class-options))))
(length (remove-duplicates class-options))))
(let* ((default-initargs (second (assoc :default-initargs class-options)))
(let* ((default-initargs (second (assoc :default-initargs class-options)))
(metaclass (or (second (assoc :metaclass class-options))
(metaclass (or (second (assoc :metaclass class-options))
'standard-class))
'standard-class))
(doc (second (assoc :documentation class-options)))
(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
`(progn
(eval-when (load eval compile)
(eval-when (load eval compile)
(ignore-errors (defclass ,@
args
)))
(ignore-errors (defclass ,@
(cdr args)
)))
(deftest ,(make-defclass-test-name class-name
(deftest ,(make-defclass-test-name class-name
"-IS-IN-ITS-METACLASS")
"-IS-IN-ITS-METACLASS")
...
@@ -50,15 +100,45 @@
...
@@ -50,15 +100,45 @@
,@(when (eq metaclass 'standard-class)
,@(when (eq metaclass 'standard-class)
`((deftest ,(make-defclass-test-name class-name
`((deftest ,(make-defclass-test-name class-name
"S-ARE-STANDARD-OBJECTS")
"S-ARE-STANDARD-OBJECTS")
(subtypep* ,class-name 'standard-object)
(subtypep*
'
,class-name 'standard-object)
t t)))
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)
)))
)))
(defmacro generate-slot-tests ()
"Generate generic tests from the read/writer/accessor functions
for slots from defclass-with-tests."
\ No newline at end of file
(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))))
ansi-tests/defclass.lsp
View file @
2b8e2331
...
@@ -65,9 +65,16 @@
...
@@ -65,9 +65,16 @@
program-error)
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
...
...
ansi-tests/ensure-generic-function.lsp
0 → 100644
View file @
2b8e2331
;-*- 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)
ansi-tests/lambda-list-keywords.lsp
View file @
2b8e2331
...
@@ -25,15 +25,16 @@
...
@@ -25,15 +25,16 @@
t)
t)
;;; No lambda list keywords are in the keyword package
;;; No lambda list keywords are in the keyword package
(deftest lambda-list-keywords.4
;;;
(deftest lambda-list-keywords.4
(some #'keywordp lambda-list-keywords)
;;;
(some #'keywordp lambda-list-keywords)
nil)
;;;
nil)
;;; Every keyword starts with an ampersand
;;; Every keyword starts with an ampersand
(deftest lambda-list-keywords.5
(deftest lambda-list-keywords.5
(notevery #'(lambda (sym)
(notevery #'(lambda (sym)
(let ((name (symbol-name sym)))
(and (symbolp sym)
(and (> (length name) 0)
(let ((name (symbol-name sym)))
(eql (aref name 0) #\&))))
(and (> (length name) 0)
(eql (aref name 0) #\&)))))
lambda-list-keywords)
lambda-list-keywords)
nil)
nil)
ansi-tests/load-objects.lsp
View file @
2b8e2331
...
@@ -5,4 +5,6 @@
...
@@ -5,4 +5,6 @@
(compile-and-load "defclass-aux.lsp")
(compile-and-load "defclass-aux.lsp")
(load "defclass.lsp")
(load "defclass.lsp")
(load "ensure-generic-function.lsp")
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment