Fix missing `without-special-symbol-access' in `funcall-with-attribute-context'
[clinton/lisp-on-lines.git] / src / attribute-test.lisp
1 (in-package :lol-test)
2
3 (in-suite lisp-on-lines)
4
5 (deftest test-attribute-value ()
6 (eval
7 '(progn
8 (define-description attribute-test-description ()
9 ((attribute-1 :value "VALUE")
10 (attribute-2 :function (constantly "VALUE"))))
11
12 (define-description attribute-test)
13
14 (define-description attribute-test-description ()
15 ((attribute-1 :value "VALUE2")
16 (attribute-2 :function (constantly "VALUE2")))
17 (:in-description attribute-test))))
18
19 (funcall-with-described-object
20 (lambda (&aux
21 (a1 (find-attribute *description* 'attribute-1))
22 (a2 (find-attribute *description* 'attribute-2))
23 )
24 (is (equalp "VALUE" (attribute-value a1)))
25 (is (equalp "VALUE" (attribute-value a2)))
26 (with-active-descriptions (attribute-test)
27 (is (equalp "VALUE2" (attribute-value a1)))
28 (is (equalp "VALUE2" (attribute-value a2)))))
29 nil
30 (find-description 'attribute-test-description)))
31
32 (deftest test-attribute-property-inheriting ()
33 (test-attribute-value)
34 (eval '(progn
35 (define-description attribute-property-test)
36 (define-description attribute-test-description ()
37 ((attribute-1 :label "attribute1")
38 (attribute-2 :label "attribute2"))
39 (:in-description attribute-property-test))))
40
41 (with-active-descriptions (attribute-property-test)
42 (with-described-object (nil (find-description 'attribute-test-description))
43 (let ((d (dynamic description)))
44 (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
45
46 (is (equalp "attribute1" (attribute-label (find-attribute d 'attribute-1))))
47 (is (equalp "attribute2" (attribute-label (find-attribute d 'attribute-2))))
48
49
50 (with-active-descriptions (attribute-test)
51 (is (equalp (attribute-value (find-attribute d 'attribute-1))
52 (attribute-value (find-attribute d 'attribute-2))))
53 (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1)))))))
54 ))
55
56 (deftest (test-attribute-with-different-class :compile-before-run t) ()
57 (eval '(progn
58 (define-layered-class
59 test-attribute-class (standard-attribute)
60 ((some-slot :initarg :some-slot
61 :layered t
62 :special t
63 :layered-accessor some-slot)))
64
65 (define-description test-attribute-with-different-class-description ()
66 ((attribute-with-different-class :attribute-class test-attribute-class :some-slot "BRILLANT!")))))
67
68 (let* ((d (find-description 'test-attribute-with-different-class-description))
69
70 (a (find-attribute d 'attribute-with-different-class)))
71 (is (eq (class-of a)
72 (find-class 'test-attribute-class)))
73 (is (equalp "BRILLANT!" (some-slot a)))))
74
75 (deftest (test-attribute-with-different-class-and-subclassed-description :compile-before-run t) ()
76 (test-attribute-with-different-class)
77 (eval '(progn
78 (define-description test-attribute-with-different-class-description-sub
79 (test-attribute-with-different-class-description)
80 ())))
81
82 (let* ((d (find-description 'test-attribute-with-different-class-description-sub))
83
84 (a (find-attribute d 'attribute-with-different-class)))
85 (is (eq (class-of a)
86 (find-class 'test-attribute-class)))
87 (is (equalp "BRILLANT!" (some-slot a)))))
88
89
90
91
92
93
94