Commit dec63c3a authored by pfdietz's avatar pfdietz

Begin adding simple inheritance tests for DEFCLASS.

parent a28c3fcf
......@@ -1452,4 +1452,28 @@ the condition to go uncaught if it cannot be classified."
(eqlt (classify-error (funcall (macro-function ',macro-name)
',macro-form nil nil))
'program-error))
t t t)))
\ No newline at end of file
t t t)))
(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 @@
(compile-and-load "defclass-aux.lsp")
(load "defclass.lsp")
(load "defclass-01.lsp")
(load "defclass-02.lsp")
(load "defclass-errors.lsp")
(load "defclass-forward-reference.lsp")
(load "ensure-generic-function.lsp")
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment