Commit 1d1d972e authored by pfdietz's avatar pfdietz
Browse files

Tests for SLOT-VALUE, METHOD-QUALIFIERS.

parent 6f0cc7e8
......@@ -19,3 +19,5 @@
(load "slot-boundp.lsp")
(load "slot-exists-p.lsp")
(load "slot-makunbound.lsp")
(load "slot-value.lsp")
(load "method-qualifiers.lsp")
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun May 11 07:14:12 2003
;;;; Contains: Tests of METHOD-QUALIFIERS
(in-package :cl-test)
(defgeneric mq-generic-function (x))
(defparameter *mq-method-1*
(defmethod mq-generic-function ((x integer)) (1+ x)))
(deftest method-qualifiers.1
(method-qualifiers *mq-method-1*)
nil)
(defclass mq-class-01 ()
(a b c))
(defparameter *mq-method-2*
(defmethod mq-generic-function :before ((x mq-class-01))
'foo))
(deftest method-qualifiers.2
(method-qualifiers *mq-method-2*)
(:before))
(defclass mq-class-02 ()
(e f g))
(defparameter *mq-method-3*
(defmethod mq-generic-function :after ((x mq-class-02))
'foo))
(deftest method-qualifiers.3
(method-qualifiers *mq-method-3*)
(:after))
(defclass mq-class-03 ()
(h i j))
(defparameter *mq-method-4*
(defmethod mq-generic-function :around ((x mq-class-03))
'foo))
(deftest method-qualifiers.4
(method-qualifiers *mq-method-4*)
(:around))
;;; Need tests on user-defined method combinations
(deftest method-qualifiers.error.1
(classify-error (method-qualifiers))
program-error)
(deftest method-qualifiers.error.2
(classify-error (method-qualifiers *mq-method-4* nil))
program-error)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat May 10 16:16:59 2003
;;;; Contains: Tests of SLOT-VALUE
(in-package :cl-test)
;;; SLOT-VALUE is used extensively elsewhere.
(defclass slot-value-class-01 ()
(a
(b :type t)
(c :type fixnum)
(d :type float)
(e :type symbol)
(f :type short-float)
(g :type single-float)
(h :type double-float)
(i :type long-float)
(j :type rational)
(k :type ratio)
(l :type cons)
(m :type string)
(n :type vector)
(o :type bit)
))
(defparameter *slot-value-test-slot-names*
'(a b c d e f g h i j k l m n o))
(defparameter *slot-value-test-slot-values*
'(t nil 10 4.0 a 1.0s0 2.0f0 3.0d0 4.0l0
5/4 2/3 (a . b) "abcd" #(1 2 3 4) 1))
(deftest slot-value.1
(let ((obj (make-instance 'slot-value-class-01))
(slot-names *slot-value-test-slot-names*)
(slot-values *slot-value-test-slot-values*))
(loop for name in slot-names
for val in slot-values
unless (and (equal (multiple-value-list
(setf (slot-value obj name) val))
(list val))
(equal (multiple-value-list
(slot-value obj name))
(list val)))
collect name))
nil)
(defclass slot-value-class-02 (slot-value-class-01)
((a :allocation :class)
(b :allocation :class)
(c :allocation :class)
(d :allocation :class)
(e :allocation :class)
(f :allocation :class)
(g :allocation :class)
(h :allocation :class)
(i :allocation :class)
(j :allocation :class)
(k :allocation :class)
(l :allocation :class)
(m :allocation :class)
(n :allocation :class)
(o :allocation :class)))
(deftest slot-value.2
(let ((obj (make-instance 'slot-value-class-02))
(slot-names *slot-value-test-slot-names*)
(slot-values *slot-value-test-slot-values*))
(loop for name in slot-names
for val in slot-values
unless (and (equal (multiple-value-list
(setf (slot-value obj name) val))
(list val))
(equal (multiple-value-list
(slot-value obj name))
(list val)))
collect name))
nil)
;;; Error tests
(deftest slot-value.error.1
(classify-error (slot-value))
program-error)
(deftest slot-value.error.2
(classify-error (slot-value (make-instance 'slot-value-class-01)))
program-error)
(deftest slot-value.error.3
(classify-error
(let ((obj (make-instance 'slot-value-class-01)))
(setf (slot-value obj 'a) t)
(slot-value obj 'a nil)))
program-error)
(deftest slot-value.error.4
(handler-case
(progn (slot-value (make-instance 'slot-value-class-01) (gensym))
:bad)
(error () :good))
:good)
(deftest slot-value.error.5
(let ((built-in-class (find-class 'built-in-class))
(slot-name (gensym)))
(loop for e in *mini-universe*
for class = (class-of e)
when (and (eq (class-of class) built-in-class)
(handler-case (progn (slot-value e slot-name) t)
(error () nil)))
collect e))
nil)
(deftest slot-value.error.6
(let ((built-in-class (find-class 'built-in-class))
(slot-name (gensym)))
(loop for e in *mini-universe*
for class = (class-of e)
when (and (eq (class-of class) built-in-class)
(handler-case (setf (slot-value e slot-name) t)
(error () nil)))
collect e))
nil)
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