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
8e4334b2
Commit
8e4334b2
authored
Apr 28, 2003
by
pfdietz
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
More tests of defclass, mostly of inheritance.
parent
c69a7873
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
569 additions
and
5 deletions
+569
-5
ansi-tests/defclass-01.lsp
ansi-tests/defclass-01.lsp
+36
-5
ansi-tests/defclass-02.lsp
ansi-tests/defclass-02.lsp
+384
-0
ansi-tests/defclass-03.lsp
ansi-tests/defclass-03.lsp
+149
-0
No files found.
ansi-tests/defclass-01.lsp
View file @
8e4334b2
...
...
@@ -791,9 +791,40 @@
(typep* #'(setf s1-26) 'generic-function)))
nil x x t)
;;;
\ No newline at end of file
(defclass class-27 ()
(a (b :initform 10) (c :initarg :c) (d :initarg :d))
(:metaclass standard-class)
(:default-initargs :d 17))
(deftest class-27.1
(let ((class (find-class 'class-27)))
(values
(subtypep* 'class-27 'standard-object)
(subtypep* 'class-27 t)
(subtypep* 'class-27 (find-class 'standard-object))
(subtypep* 'class-27 (find-class t))
(subtypep* class 'standard-object)
(subtypep* class t)
(subtypep* class (find-class 'standard-object))
(subtypep* class (find-class t))))
t t t t t t t t)
(deftest class-27.2
(let ((c (make-instance 'class-27)))
(values
(slot-boundp* c 'a)
(slot-value c 'b)
(slot-boundp* c 'c)
(slot-value c 'd)))
nil 10 nil 17)
(deftest class-27.3
(let ((c (make-instance 'class-27 :c 26 :d 43)))
(values
(slot-boundp* c 'a)
(slot-value c 'b)
(slot-value c 'c)
(slot-value c 'd)))
nil 10 26 43)
ansi-tests/defclass-02.lsp
View file @
8e4334b2
...
...
@@ -315,6 +315,30 @@
z
x y z)))
;;; Same as class-redefinition.1, but reverse the order in which
;;; the classes are redefined.
(deftest class-redefinition.3
(let*
((cobj1 (eval '(defclass class-redef-03a ()
((a :allocation :class :initform 'x)))))
(cobj2 (eval '(defclass class-redef-03b (class-redef-03a)
((a :allocation :instance)))))
(cobj4 (eval '(defclass class-redef-03b (class-redef-03a)
((a :allocation :instance)))))
(cobj3 (eval '(defclass class-redef-03a ()
((a :allocation :class :initform 'x))))))
(values
(eqt cobj1 cobj3)
(eqt cobj2 cobj4)
(class-name cobj1)
(class-name cobj2)
(slot-value (make-instance 'class-redef-03a) 'a)
(slot-value (make-instance 'class-redef-03b) 'a)))
t t
class-redef-03a
class-redef-03b
x x)
;;; Initforms are inherited even if :allocation changes
(defclass class-0211a ()
...
...
@@ -329,3 +353,363 @@
(slot-value (make-instance 'class-0211b) 'a))
x x)
;;;
;;; Inheritance of :initargs
(defclass class-0212a ()
((a :initarg :a1)))
(defclass class-0212b (class-0212a)
((a :initarg :a2)
(b :initarg :b)))
(deftest class-0212.1
(let ((c (make-instance 'class-0212a :a1 'x)))
(values
(typep* c 'class-0212a)
(typep* c 'class-0212b)
(slot-value c 'a)
(slot-exists-p c 'b)))
t nil x nil)
(deftest class-0212.2
(let ((c (make-instance 'class-0212b :a1 'x)))
(values
(typep* c 'class-0212a)
(typep* c 'class-0212b)
(slot-value c 'a)
(slot-boundp* c 'b)))
t t x nil)
(deftest class-0212.3
(let ((c (make-instance 'class-0212b :a2 'x :b 'y)))
(values
(typep* c 'class-0212a)
(typep* c 'class-0212b)
(slot-value c 'a)
(slot-value c 'b)))
t t x y)
(deftest class-0212.4
(let ((c (make-instance 'class-0212b :a1 'z :a2 'x :b 'y)))
(values
(typep* c 'class-0212a)
(typep* c 'class-0212b)
(slot-value c 'a)
(slot-value c 'b)))
t t z y)
(deftest class-0212.5
(let ((c (make-instance 'class-0212b :a2 'x :b 'y :a1 'z)))
(values
(typep* c 'class-0212a)
(typep* c 'class-0212b)
(slot-value c 'a)
(slot-value c 'b)))
t t x y)
;;;
(defclass class-0213a ()
((a :initarg :a1)))
(defclass class-0213b (class-0213a)
(b))
(deftest class-0213.1
(let ((c (make-instance 'class-0213a :a1 'x)))
(values
(typep* c 'class-0213a)
(typep* c 'class-0213b)
(slot-value c 'a)
(slot-exists-p c 'b)))
t nil x nil)
(deftest class-0213.2
(let ((c (make-instance 'class-0213b :a1 'x)))
(values
(typep* c 'class-0213a)
(typep* c 'class-0213b)
(slot-value c 'a)
(slot-boundp* c 'b)))
t t x nil)
;;;
(defclass class-0214a ()
((a :initarg :a1 :allocation :class)))
(defclass class-0214b (class-0214a)
(b))
(deftest class-0214.1
(let ((c (make-instance 'class-0214a :a1 'x)))
(values
(typep* c 'class-0214a)
(typep* c 'class-0214b)
(slot-value c 'a)
(slot-exists-p c 'b)))
t nil x nil)
(deftest class-0214.2
(let ((c (make-instance 'class-0214b :a1 'y)))
(values
(typep* c 'class-0214a)
(typep* c 'class-0214b)
(slot-value c 'a)
(slot-boundp* c 'b)))
t t y nil)
;;;
(defclass class-0215a ()
((a :initarg :a1 :allocation :instance)))
(defclass class-0215b (class-0215a)
((a :allocation :class)))
(deftest class-0215.1
(let ((c (make-instance 'class-0215a :a1 'x)))
(values
(typep* c 'class-0215a)
(typep* c 'class-0215b)
(slot-value c 'a)))
t nil x)
(deftest class-0215.2
(let ((c (make-instance 'class-0215b :a1 'y)))
(values
(typep* c 'class-0215a)
(typep* c 'class-0215b)
(slot-value c 'a)))
t t y)
;;; Tests of defaulted initargs
(defclass class-0216a ()
((a :initarg :a1)
(b :initarg :b1)))
(defclass class-0216b (class-0216a)
()
(:default-initargs :a1 'x))
(deftest class-0216.1
(let ((c (make-instance 'class-0216a)))
(values
(typep* c 'class-0216a)
(typep* c 'class-0216b)
(slot-boundp c 'a)
(slot-boundp c 'b)))
t nil nil nil)
(deftest class-0216.2
(let ((c (make-instance 'class-0216b)))
(values
(typep* c 'class-0216a)
(typep* c 'class-0216b)
(slot-value c 'a)
(slot-boundp c 'b)))
t t x nil)
;;;
(defclass class-0217a ()
((a :initarg :a1)
(b :initarg :b1)
(c :initarg :c1)
(d :initarg :d1))
(:default-initargs :a1 10 :b1 20))
(defclass class-0217b (class-0217a)
()
(:default-initargs :a1 30 :c1 40))
(deftest class-0217.1
(let ((c (make-instance 'class-0217a)))
(values
(map-slot-boundp* c '(a b c d))
(map-slot-value c '(a b))))
(t t nil nil)
(10 20))
(deftest class-0217.2
(let ((c (make-instance 'class-0217a :a1 'x :c1 'y)))
(values
(map-slot-boundp* c '(a b c d))
(map-slot-value c '(a b c))))
(t t t nil)
(x 20 y))
(deftest class-0217.3
(let ((c (make-instance 'class-0217b)))
(values
(map-slot-boundp* c '(a b c d))
(map-slot-value c '(a b c))))
(t t t nil)
(30 20 40))
(deftest class-0217.4
(let ((c (make-instance 'class-0217b :a1 'x :d1 'y)))
(values
(map-slot-boundp* c '(a b c d))
(map-slot-value c '(a b c d))))
(t t t t)
(x 20 40 y))
;;;
(defclass class-0218a ()
((a :initarg :a1))
(:default-initargs :a1 'x))
(defclass class-0218b (class-0218a)
((a :initform 'y)))
(deftest class-0218.1
(let ((c (make-instance 'class-0218a)))
(slot-value c 'a))
x)
(deftest class-0218.2
(let ((c (make-instance 'class-0218b)))
(slot-value c 'a))
x)
;;;
(declaim (special *class-0219-a-1* *class-0219-a-2*))
(defclass class-0219a ()
((a :initarg :a1))
(:default-initargs :a1 (setf *class-0219-a-1* 'x)))
(defclass class-0219b ()
((a :initarg :a1))
(:default-initargs :a1 (setf *class-0219-a-2* 'y)))
(deftest class-0219.1
(let ((*class-0219-a-1* nil))
(values
(slot-value (make-instance 'class-0219a) 'a)
*class-0219-a-1*))
x x)
(deftest class-0219.2
(let ((*class-0219-a-1* nil)
(*class-0219-a-2* nil))
(values
(slot-value (make-instance 'class-0219b) 'a)
*class-0219-a-1*
*class-0219-a-2*))
y nil y)
;;;
(defclass class-0220a ()
((a :type (integer 0 10) :initarg :a)))
(defclass class-0220b (class-0220a)
((a :type (integer -5 5))))
(deftest class-0220.1
(slot-value (make-instance 'class-0220a :a 10) 'a)
10)
(deftest class-0220.2
(slot-value (make-instance 'class-0220a :a 0) 'a)
0)
(deftest class-0220.3
(slot-value (make-instance 'class-0220b :a 0) 'a)
0)
(deftest class-0220.4
(slot-value (make-instance 'class-0220b :a 5) 'a)
5)
;;;
(defclass class-0221a ()
(a b c)
(:documentation "This is class class-0221a"))
(defclass class-0221b (class-0221a)
())
(defclass class-0221c (class-0221a)
()
(:documentation "This is class class-0221c"))
(deftest class-0221.1
(let* ((cl (find-class 'class-0221a))
(doc (documentation cl t)))
(or (null doc)
(equalt doc "This is class class-0221a")))
t)
(deftest class-0221.2
(let* ((cl (find-class 'class-0221b))
(doc (documentation cl t)))
doc)
nil)
(deftest class-0221.3
(let* ((cl (find-class 'class-0221c))
(doc (documentation cl t)))
(or (null doc)
(equalt doc "This is class class-0221c")))
t)
;;;
(defclass class-0222a ()
((s1 :reader s1-r :writer s1-w :accessor s1-acc)))
(defclass class-0222b (class-0222a)
())
(deftest class-0222.1
(let ((c (make-instance 'class-0222a)))
(values
(s1-w 'x c)
(s1-r c)
(s1-acc c)
(setf (s1-acc c) 'y)
(s1-r c)))
x x x y y)
(deftest class-0222.2
(let ((c (make-instance 'class-0222b)))
(values
(s1-w 'x c)
(s1-r c)
(s1-acc c)
(setf (s1-acc c) 'y)
(s1-r c)))
x x x y y)
;;;
(defclass class-0223a ()
((s1 :reader s-r :writer s-w :accessor s-acc)))
(defclass class-0223b (class-0223a)
((s2 :reader s-r :writer s-w :accessor s-acc)))
(deftest class-0223.1
(let ((c (make-instance 'class-0223b)))
(values
(setf (slot-value c 's1) 'x)
(setf (slot-value c 's2) 'y)
(s-r c)
(s-acc c)
(s-w 'z c)
(slot-value c 's1)
(slot-value c 's2)
(s-r c)
(s-acc c)))
x y y y z x z z z)
ansi-tests/defclass-03.lsp
0 → 100644
View file @
8e4334b2
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Apr 27 16:23:59 2003
;;;; Contains: Tests of DEFCLASS with more involved inheritance
(in-package :cl-test)
;;;
(defclass class-0301a ()
(a b))
(defclass class-0301b ()
(a c))
(defclass class-0301c (class-0301a class-0301b)
(d))
(deftest class-0301.1
(let ((c (make-instance 'class-0301c)))
(values
(typep* c 'class-0301a)
(typep* c 'class-0301b)
(typep* c 'class-0301c)
(typep* c (find-class 'class-0301a))
(typep* c (find-class 'class-0301b))
(typep* c (find-class 'class-0301c))
(map-slot-boundp* c '(a b c d))
(setf (slot-value c 'a) 'w)
(setf (slot-value c 'b) 'x)
(setf (slot-value c 'c) 'y)
(setf (slot-value c 'd) 'z)
(map-slot-boundp* c '(a b c d))
(map-slot-value c '(a b c d))))
t t t
t t t
(nil nil nil nil)
w x y z
(t t t t)
(w x y z))
;;;
(defclass class-0302a ()
((a :initform 'x) b (c :initform 'w)))
(defclass class-0302b ()
((a :initform 'y) (b :initform 'z)))
(defclass class-0302c (class-0302a class-0302b)
(a b (c :initform 'v) d))
(deftest class-0302.1
(let ((c (make-instance 'class-0302c)))
(values
(map-slot-boundp* c '(a b c d))
(map-slot-value c '(a b c))))
(t t t nil)
(x z v))
;;;
(defclass class-0303a ()
((a :allocation :class) b))
(defclass class-0303b ()
(a (b :allocation :class)))
(defclass class-0303c (class-0303a class-0303b) ())
(deftest class-0303.1
(let ((c1 (make-instance 'class-0303a))
(c2 (make-instance 'class-0303b))
(c3 (make-instance 'class-0303c)))
(slot-makunbound c1 'a)
(slot-makunbound c2 'b)
(values
(loop for c in (list c1 c2 c3)
collect (map-slot-boundp* c '(a b)))
(list (setf (slot-value c1 'a) 'x1)
(slot-boundp* c2 'a)
(slot-value c3 'a))
(list (setf (slot-value c2 'a) 'x2)
(slot-value c1 'a)
(slot-value c2 'a)
(slot-value c3 'a))
(list (setf (slot-value c3 'a) 'x3)
(slot-value c1 'a)
(slot-value c2 'a)
(slot-value c3 'a))
;;;
(list (setf (slot-value c1 'b) 'y1)
(slot-value c1 'b)
(slot-boundp* c2 'b)
(slot-boundp* c3 'b))
(list (setf (slot-value c2 'b) 'y2)
(slot-value c1 'b)
(slot-value c2 'b)
(slot-boundp c3 'b))
(list (setf (slot-value c3 'b) 'y3)
(slot-value c1 'b)
(slot-value c2 'b)
(slot-value c3 'b))))
((nil nil) (nil nil) (nil nil))
(x1 nil x1)
(x2 x1 x2 x1)
(x3 x3 x2 x3)
;;
(y1 y1 nil nil)
(y2 y1 y2 nil)
(y3 y1 y2 y3))
;;;
(defclass class-0304a ()
((a :initform 'x)))
(defclass class-0304b (class-0304a) ())
(defclass class-0304c (class-0304a)
((a :initform 'y)))
(defclass class-0304d (class-0304b class-0304c)
())
(deftest class-0304.1
(slot-value (make-instance 'class-0304d) 'a)
y)
;;;
(defclass class-0305a ()
((a :initarg :a))
(:default-initargs :a 'x))
(defclass class-0305b (class-0305a) ())
(defclass class-0305c (class-0305a)
()
(:default-initargs :a 'y))
(defclass class-0305d (class-0305b class-0305c)
())
(deftest class-0305.1
(slot-value (make-instance 'class-0305d) 'a)
y)
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