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

Begin adding simple inheritance tests for DEFCLASS.

parent a28c3fcf
No related branches found
No related tags found
No related merge requests found
...@@ -1452,4 +1452,28 @@ the condition to go uncaught if it cannot be classified." ...@@ -1452,4 +1452,28 @@ the condition to go uncaught if it cannot be classified."
(eqlt (classify-error (funcall (macro-function ',macro-name) (eqlt (classify-error (funcall (macro-function ',macro-name)
',macro-form nil nil)) ',macro-form nil nil))
'program-error)) 'program-error))
t t t))) t t t)))
\ No newline at end of file
(defun typep* (element type)
(not (not (typep element type))))
(defun applyf (fn &rest args)
#'(lambda (&rest more-args) (apply fn (append args more-args))))
(defun slot-boundp* (object slot)
(notnot (slot-boundp object slot)))
(defun slot-exists-p* (object slot)
(notnot (slot-exists-p object slot)))
(defun map-slot-boundp* (c slots)
(mapcar (applyf #'slot-boundp c) slots))
(defun map-slot-exists-p* (c slots)
(mapcar (applyf #'slot-exists-p* c) slots))
(defun map-slot-value (c slots)
(mapcar (applyf #'slot-value c) slots))
(defun map-typep* (object types)
(mapcar (applyf #'typep* object) types))
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Fri Apr 25 07:16:57 2003
;;;; Contains: Tests of DEFCLASS with simple inheritance
(in-package :cl-test)
;;;
(defclass class-0201 ()
((a :initform 'x) (b :allocation :instance) (c :reader class-0201-c)))
(defclass class-0202 (class-0201)
(d (e :initform 'y) (f :allocation :instance)))
(deftest class-0201.1
(let ((c (make-instance 'class-0201)))
(values (map-slot-boundp* c '(a b c))
(map-slot-exists-p* c '(a b c))
(slot-value c 'a)
(map-typep* c (list 'class-0201 'class-0202
(find-class 'class-0201)
(find-class 'class-0202)))
(class-name (class-of c))
))
(t nil nil)
(t t t)
x
(t nil t nil)
class-0201)
(deftest class-0202.1
(let ((c (make-instance 'class-0202)))
(values (map-slot-boundp* c '(a b c d e f))
(map-slot-value c '(a e))
(map-typep* c (list 'class-0201 'class-0202
(find-class 'class-0201)
(find-class 'class-0202)))
(class-name (class-of c))
))
(t nil nil nil t nil)
(x y)
(t t t t)
class-0202)
;;;
(defclass class-0203 ()
((a :allocation :class) (b :allocation :instance)))
(defclass class-0204 (class-0203)
(c d))
(deftest class-0203.1
(let ((c1 (make-instance 'class-0203))
(c2 (make-instance 'class-0204)))
(values
(map-slot-boundp* c1 '(a b))
(map-slot-boundp* c2 '(a b c d))
(setf (slot-value c1 'a) 'x)
(map-slot-boundp* c1 '(a b))
(map-slot-boundp* c2 '(a b c d))
(slot-value c1 'a)
(slot-value c2 'a)
(eq (slot-makunbound c1 'a) c1)
(map-slot-boundp* c1 '(a b))
(map-slot-boundp* c2 '(a b c d))))
(nil nil)
(nil nil nil nil)
x
(t nil)
(t nil nil nil)
x x
t
(nil nil)
(nil nil nil nil))
(deftest class-0203.2
(let ((c1 (make-instance 'class-0203))
(c2 (make-instance 'class-0204)))
(values
(map-slot-boundp* c1 '(a b))
(map-slot-boundp* c2 '(a b c d))
(setf (slot-value c1 'a) 'x)
(map-slot-boundp* c1 '(a b))
(map-slot-boundp* c2 '(a b c d))
(slot-value c1 'a)
(slot-value c2 'a)
(eq (slot-makunbound c2 'a) c1)
(map-slot-boundp* c1 '(a b))
(map-slot-boundp* c2 '(a b c d))))
(nil nil)
(nil nil nil nil)
x
(t nil)
(t nil nil nil)
x x
t
(nil nil)
(nil nil nil nil))
\ No newline at end of file
...@@ -6,6 +6,7 @@ ...@@ -6,6 +6,7 @@
(compile-and-load "defclass-aux.lsp") (compile-and-load "defclass-aux.lsp")
(load "defclass.lsp") (load "defclass.lsp")
(load "defclass-01.lsp") (load "defclass-01.lsp")
(load "defclass-02.lsp")
(load "defclass-errors.lsp") (load "defclass-errors.lsp")
(load "defclass-forward-reference.lsp") (load "defclass-forward-reference.lsp")
(load "ensure-generic-function.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