From dec63c3a6cdd5a899447ef46e871bf212cd51cc4 Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Sat, 26 Apr 2003 13:51:11 +0000 Subject: [PATCH] Begin adding simple inheritance tests for DEFCLASS. --- ansi-tests/ansi-aux.lsp | 26 ++++++++- ansi-tests/defclass-02.lsp | 105 ++++++++++++++++++++++++++++++++++++ ansi-tests/load-objects.lsp | 1 + 3 files changed, 131 insertions(+), 1 deletion(-) create mode 100644 ansi-tests/defclass-02.lsp diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 5fac9ada..f946aa91 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -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)) diff --git a/ansi-tests/defclass-02.lsp b/ansi-tests/defclass-02.lsp new file mode 100644 index 00000000..ccf934d6 --- /dev/null +++ b/ansi-tests/defclass-02.lsp @@ -0,0 +1,105 @@ +;-*- 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 diff --git a/ansi-tests/load-objects.lsp b/ansi-tests/load-objects.lsp index f5113753..b9b1bbea 100644 --- a/ansi-tests/load-objects.lsp +++ b/ansi-tests/load-objects.lsp @@ -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") -- GitLab