diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index ecf03cdc37ccf634c6d640624311d3ce81227653..5e4454d7da0a141b8210738d0216df07dc1b8b9a 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -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))) diff --git a/ansi-tests/change-class.lsp b/ansi-tests/change-class.lsp index f02f660de98b5f8345c57124d2482708e61cef31..04d0d4925dd3ce5eadb3153f01da69b42af4f9ec 100644 --- a/ansi-tests/change-class.lsp +++ b/ansi-tests/change-class.lsp @@ -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) diff --git a/ansi-tests/load-eval-and-compile.lsp b/ansi-tests/load-eval-and-compile.lsp index 64b64aa39b424a1dc14425d56b2d50aa4394cba3..c8af8c66c4e398d84588467263d5aea85ed46b47 100644 --- a/ansi-tests/load-eval-and-compile.lsp +++ b/ansi-tests/load-eval-and-compile.lsp @@ -9,3 +9,5 @@ (load "define-compiler-macro.lsp") (load "define-symbol-macro.lsp") (load "defmacro.lsp") +(load "the.lsp") + diff --git a/ansi-tests/load-objects.lsp b/ansi-tests/load-objects.lsp index 4f0344c3ab228b3321616ac2cd702a3f16c4c026..62eeccb453fb14791fd4dfe9f05d09d7039a28f5 100644 --- a/ansi-tests/load-objects.lsp +++ b/ansi-tests/load-objects.lsp @@ -16,4 +16,6 @@ (load "shared-initialize.lsp") (load "change-class.lsp") (load "update-instance-for-different-class.lsp") +(load "slot-boundp,lsp") + diff --git a/ansi-tests/slot-boundp.lsp b/ansi-tests/slot-boundp.lsp new file mode 100644 index 0000000000000000000000000000000000000000..0ceba738465173a72557472011d9c7ca47225300 --- /dev/null +++ b/ansi-tests/slot-boundp.lsp @@ -0,0 +1,72 @@ +;-*- 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) diff --git a/ansi-tests/the.lsp b/ansi-tests/the.lsp new file mode 100644 index 0000000000000000000000000000000000000000..afe64bfc7d500a1ec089a5cb7ca5a86a83cfdde0 --- /dev/null +++ b/ansi-tests/the.lsp @@ -0,0 +1,27 @@ +;-*- 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) diff --git a/ansi-tests/universe.lsp b/ansi-tests/universe.lsp index d7383d16367e2be76e9f853a877f5af7e20441df..19e132dedf17e166e07712ba1538efd6261266b5 100644 --- a/ansi-tests/universe.lsp +++ b/ansi-tests/universe.lsp @@ -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))))