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

Added slot-boundp tests, some THE tests. Error tests for change-class on...

Added slot-boundp tests, some THE tests.  Error tests for change-class on builtin classes.  Added more elements to *mini-universe*.
parent dadd7120
No related branches found
No related tags found
No related merge requests found
......@@ -1481,4 +1481,4 @@ the condition to go uncaught if it cannot be classified."
(defun slot-value-or-nil (object slot-name)
(and (slot-exists-p object slot-name)
(slot-boundp object slot-name)
(slot-value object slot-name)))
\ No newline at end of file
(slot-value object slot-name)))
......@@ -608,3 +608,33 @@
(change-class obj new-class '(nonsense) 'a)))
program-error)
;;; According to the page for BUILT-IN-CLASS, using CHANGE-CLASS
;;; to change the class to/from a builtin class should raise a
;;; signal of type ERROR.
(deftest change-class.error.5
(let ((built-in-class (find-class 'built-in-class)))
(loop for e in *mini-universe*
for class = (class-of e)
when (and (eq (class-of class) built-in-class)
(handler-case
(progn
(change-class (make-instance 'change-class-class-01a)
class)
t)
(error () nil)))
collect e))
nil)
(deftest change-class.error.6
(let ((built-in-class (find-class 'built-in-class)))
(loop for e in *mini-universe*
for class = (class-of e)
when (and (eq (class-of class) built-in-class)
(handler-case
(progn
(change-class e (find-class 'change-class-class-01a))
t)
(error () nil)))
collect e))
nil)
......@@ -9,3 +9,5 @@
(load "define-compiler-macro.lsp")
(load "define-symbol-macro.lsp")
(load "defmacro.lsp")
(load "the.lsp")
......@@ -16,4 +16,6 @@
(load "shared-initialize.lsp")
(load "change-class.lsp")
(load "update-instance-for-different-class.lsp")
(load "slot-boundp,lsp")
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue May 6 05:53:32 2003
;;;; Contains: Tests of SLOT-BOUNDP
(in-package :cl-test)
;;; SLOT-BOUNDP is extensively tested in other files as well
(defclass slot-boundp-class-01 ()
(a (b :initarg :b) (c :initform 'x)))
(deftest slot-boundp.1
(let ((obj (make-instance 'slot-boundp-class-01)))
(slot-boundp obj 'a))
nil)
(deftest slot-boundp.2
(let ((obj (make-instance 'slot-boundp-class-01)))
(setf (slot-value obj 'a) nil)
(notnot-mv (slot-boundp obj 'a)))
t)
(deftest slot-boundp.3
(let ((obj (make-instance 'slot-boundp-class-01 :b nil)))
(notnot-mv (slot-boundp obj 'b)))
t)
(deftest slot-boundp.4
(let ((obj (make-instance 'slot-boundp-class-01)))
(notnot-mv (slot-boundp obj 'c)))
t)
(deftest slot-boundp.5
(let ((obj (make-instance 'slot-boundp-class-01)))
(slot-makunbound obj 'c)
(slot-boundp obj 'c))
nil)
;;; Error tests
(deftest slot-boundp.error.1
(classify-error (slot-boundp))
program-error)
(deftest slot-boundp.error.2
(classify-error (let ((obj (make-instance 'slot-boundp-class-01)))
(slot-boundp obj)))
program-error)
(deftest slot-boundp.error.3
(classify-error (let ((obj (make-instance 'slot-boundp-class-01)))
(slot-boundp obj 'a nil)))
program-error)
(deftest slot-boundp.error.4
(let ((err (classify-error
(let ((obj (make-instance 'slot-boundp-class-01)))
(slot-boundp obj 'nonexistent-slot)))))
(and err (notnot (subtypep err 'error))))
t)
;;; SLOT-BOUNDP should signal an error on elements of built-in-classes
(deftest slot-boundp.error.5
(let ((built-in-class (find-class 'built-in-class)))
(loop for e in *mini-universe*
for class = (class-of e)
when (and (eq (class-of class) built-in-class)
(handler-case (progn (slot-boundp e 'foo) t)
(error () nil)))
collect e))
nil)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue May 6 06:48:48 2003
;;;; Contains: Tests of THE
(in-package :cl-test)
(deftest the.1
(the (values) (values)))
(deftest the.2
(the (values) 'a)
a)
(deftest the.3
(loop for e in *universe*
for x = (multiple-value-list (eval `(the (values) (quote ,e))))
unless (and x (not (cdr x)) (eql (car x) e))
collect e)
nil)
(deftest the.4
(loop for e in *universe*
for x = (multiple-value-list (eval `(the ,(type-of e) (quote ,e))))
unless (and x (not (cdr x)) (eql (car x) e))
collect e)
nil)
......@@ -377,21 +377,22 @@
(defvar *mini-universe*
(remove-duplicates
(mapcar #'first
(list *symbols*
*numbers*
*characters*
(mapcar #'copy-seq *strings*)
*conses*
*condition-objects*
*package-objects*
*arrays*
*hash-tables*
*pathnames*
*streams*
*readtables*
*structures*
*functions*
*random-states*))))
(append
(mapcar #'first
(list *symbols*
*numbers*
*characters*
(list (copy-seq (first *strings*)))
*conses*
*condition-objects*
*package-objects*
*arrays*
*hash-tables*
*pathnames*
*streams*
*readtables*
*structures*
*functions*
*random-states*))
'(;;; Others to fill in gaps
1.2s0 1.3f0 1.5d0 1.8l0 3/5 10000000000000000000000))))
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