Commit 530092fa authored by pfdietz's avatar pfdietz
Browse files

Added tests for WITH-SLOTS.

parent 9633db44
...@@ -29,3 +29,4 @@ ...@@ -29,3 +29,4 @@
(load "make-load-form.lsp") (load "make-load-form.lsp")
(load "make-load-form-saving-slots.lsp") (load "make-load-form-saving-slots.lsp")
(load "with-accessors.lsp") (load "with-accessors.lsp")
(load "with-slots.lsp")
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat May 17 18:04:10 2003
;;;; Contains: Tests of WITH-SLOTS
(in-package :cl-test)
(deftest with-slots.1
(with-slots () nil)
nil)
(deftest with-slots.2
(with-slots () nil (values)))
(deftest with-slots.3
(with-slots () nil (values 'a 'b 'c 'd 'e 'f))
a b c d e f)
(deftest with-slots.4
(let ((x 0) (y 10) (z 20))
(values
x y z
(with-slots () (incf x) (incf y 3) (incf z 100))
x y z))
0 10 20
120
1 13 120)
;;; with-slots is an implicit progn, not a tagbody
(deftest with-slots.5
(block done
(tagbody
(with-slots () nil
(go 10)
10
(return-from done :bad))
10
(return-from done :good)))
:good)
;;; with-slots has no implicit block
(deftest with-slots.6
(block nil
(with-slots () nil (return :good))
(return :bad))
:good)
;;; Tests on standard objects
(defclass with-slots-class-01 () ((a :initarg :a)
(b :initarg :b)
(c :initarg :c)))
(deftest with-slots.7
(let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
(with-slots (a b c) obj (values a b c)))
x y z)
(deftest with-slots.8
(let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
(with-slots
(a b c) obj
(values (setf a 'p) (setf b 'q) (setf c 'r)
(map-slot-value obj '(a b c)))))
p q r (p q r))
(deftest with-slots.9
(let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
(with-slots
(a b c) obj
(values (setq a 'p) (setq b 'q) (setq c 'r)
(map-slot-value obj '(a b c)))))
p q r (p q r))
(deftest with-slots.10
(let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
(with-slots ((a2 a) (b2 b) (c2 c)) obj (values a2 b2 c2)))
x y z)
(deftest with-slots.11
(let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
(with-slots
((a2 a) (b2 b) (c2 c)) obj
(values (setf a2 'p) (setf b2 'q) (setf c2 'r)
(map-slot-value obj '(a b c)))))
p q r (p q r))
(deftest with-slots.12
(let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
(with-slots
((a2 a) (b2 b) (c2 c)) obj
(values (setq a2 'p) (setq b2 'q) (setq c2 'r)
(map-slot-value obj '(a b c)))))
p q r (p q r))
(deftest with-slots.13
(let ((obj (make-instance 'with-slots-class-01)))
(with-slots
(a b c) obj
(values (setf a 'p) (setf b 'q) (setf c 'r)
(map-slot-value obj '(a b c)))))
p q r (p q r))
(deftest with-slots.14
(let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3)))
(with-slots (a b c) obj
(let ((obj (make-instance 'with-slots-class-01
:a 'bad :b 'bad :c 'bad)))
(values a b c))))
1 2 3)
(deftest with-slots.15
(let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3)))
(with-slots (a b c) obj
(with-slots
((a2 a) (b2 b) (c2 c))
(make-instance 'with-slots-class-01
:a 'bad :b 'bad :c 'bad)
(values a b c))))
1 2 3)
(deftest with-slots.16
(let ((obj (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 'bad)))
(with-slots (a b c) obj
(with-slots
(a b c)
(make-instance 'with-slots-class-01 :a 1 :b 2 :c 3)
(values a b c))))
1 2 3)
(deftest with-slots.17
(let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 'bad)))
(with-slots (a b) obj
(with-slots
(c)
(make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 3)
(values a b c))))
1 2 3)
;;; If slot is unbound, act as if slot-value had been called
(defmethod slot-unbound ((class (eql (find-class 'with-slots-class-01)))
instance slot-name)
'missing)
(deftest with-slots.18
(let ((obj (make-instance 'with-slots-class-01)))
(with-slots (a b c) obj (values a b c)))
missing missing missing)
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