← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/slot-makunbound.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/slot-makunbound.lsp
 
1
;-*- Mode:     Lisp -*-
 
2
;;;; Author:   Paul Dietz
 
3
;;;; Created:  Sat May 10 14:39:01 2003
 
4
;;;; Contains: Tests for SLOT-MAKUNBOUND
 
5
 
 
6
(in-package :cl-test)
 
7
 
 
8
;;; This function is heavily tested in other files as well
 
9
 
 
10
(defclass slot-makunbound-class-01 ()
 
11
  (a
 
12
   (b :allocation :instance)
 
13
   (c :allocation :class)
 
14
   (d :type fixnum)
 
15
   (e :type t)
 
16
   (f :type cons)))
 
17
 
 
18
(deftest slot-makunbound.1
 
19
  (loop for slot-name in '(a b c d e)
 
20
        unless
 
21
        (let ((obj (allocate-instance (find-class 'slot-makunbound-class-01))))
 
22
          (and
 
23
           (equalt (multiple-value-list (slot-makunbound obj slot-name))
 
24
                   (list obj))
 
25
           (not (slot-boundp obj slot-name))))
 
26
        collect slot-name)
 
27
  nil)
 
28
 
 
29
(deftest slot-makunbound.2
 
30
  (loop for slot-name in '(a b c d e)
 
31
        for slot-value in '(t t t 10 t '(a))
 
32
        unless
 
33
        (let ((obj (allocate-instance (find-class 'slot-makunbound-class-01))))
 
34
          (setf (slot-value obj slot-name) slot-value)
 
35
          (and
 
36
           (equalt (multiple-value-list (slot-makunbound obj slot-name))
 
37
                   (list obj))
 
38
           (not (slot-boundp obj slot-name))))
 
39
        collect slot-name)
 
40
  nil)
 
41
 
 
42
;;; Order of evaluation test(s)
 
43
 
 
44
(deftest slot-makunbound.order.1
 
45
  (let ((obj (make-instance 'slot-makunbound-class-01))
 
46
        (i 0) x y)
 
47
    (values
 
48
     (eqt (slot-makunbound (progn (setf x (incf i)) obj)
 
49
                           (progn (setf y (incf i)) 'a))
 
50
          obj)
 
51
     i x y))
 
52
  t 2 1 2)
 
53
 
 
54
(deftest slot-makunbound.order.2
 
55
  (let ((obj (make-instance 'slot-makunbound-class-01))
 
56
        (i 0) x y)
 
57
    (setf (slot-value obj 'a) t)
 
58
    (values
 
59
     (eqt (slot-makunbound (progn (setf x (incf i)) obj)
 
60
                           (progn (setf y (incf i)) 'a))
 
61
          obj)
 
62
     i x y))
 
63
  t 2 1 2)
 
64
 
 
65
;;; Error cases
 
66
 
 
67
(deftest slot-makunbound.error.1
 
68
  (signals-error (slot-makunbound) program-error)
 
69
  t)
 
70
 
 
71
(deftest slot-makunbound.error.2
 
72
  (signals-error (slot-makunbound (make-instance 'slot-makunbound-class-01))
 
73
                 program-error)
 
74
  t)
 
75
 
 
76
(deftest slot-makunbound.error.3
 
77
  (signals-error (slot-makunbound (make-instance 'slot-makunbound-class-01)
 
78
                                   'a nil)
 
79
                 program-error)
 
80
  t)
 
81
 
 
82
(deftest slot-makunbound.error.4
 
83
  (let ((built-in-class (find-class 'built-in-class)))
 
84
    (loop for e in *mini-universe*
 
85
          for class = (class-of e)
 
86
          when (and (eq (class-of class) built-in-class)
 
87
                    (handler-case (progn (slot-makunbound e 'foo) t)
 
88
                                  (error () nil)))
 
89
          collect e))
 
90
  nil)
 
91