thisthis
(in-package :computed-class)
(defpackage :computed-class-test
(:use :cl :computed-class :closer-mop :arnesi :stefil))
(eval-always
(import '(find-slot computed-state-or-nil computed-effective-slot-definition current-pulse
slot-value-using-class-body setf-slot-value-using-class-body
enable-sharp-boolean-syntax standard-instance-access-form computed-state-p
log.dribble log.debug log.info log.warn log.error
cs-kind cs-variable cs-depends-on)
(find-package :computed-class-test)))
(in-package :computed-class-test)
(enable-sharp-boolean-syntax)
(defsuite computed-class)
(in-suite computed-class)
(define-computed-universe compute-as :name "Default computed-class-test universe")
(define-computed-universe separated-compute-as :name "Separated computed-class-test universe")
(deftest defclass1 ()
(finishes
(defclass computed-1 ()
()
(:metaclass computed-class))
(defclass computed-2 ()
((slot-a
:initform (compute-as 1)))
(:metaclass computed-class))
(let ((class
(defclass computed-3 ()
((a)
#+sbcl(b :computed-in nil)
(c :computed-in compute-as))
(:metaclass computed-class))))
(declare (type standard-class class))
(flet ((computed-slot-p (slot-name)
(typep (find-slot class slot-name) 'computed-effective-slot-definition)))
(finalize-inheritance class)
(is (not (computed-slot-p 'a)))
#+sbcl(is (not (computed-slot-p 'b)))
(is (computed-slot-p 'c))))
(defclass computed-4 ()
((slot-a
:initform (compute-as 0))
(slot-b
:initform (compute-as 1)))
(:metaclass computed-class))
(let ((class
(defclass computed-5 ()
((a)
(c :computed-in compute-as))
(:metaclass computed-class*))))
(flet ((computed-slot-p (slot-name)
(typep (find-slot class slot-name) 'computed-effective-slot-definition)))
(finalize-inheritance class)
(is (not (computed-slot-p 'a)))
(is (computed-slot-p 'c))))))
(deftest subclassing1 ()
(defclass super ()
((a
:accessor a-of
:initform (compute-as 42))
(b
:accessor b-of
:initform (compute-as (1+ (a-of -self-)))))
(:metaclass computed-class*))
(defclass level0-1 (super)
((x))
(:metaclass computed-class*))
(defclass level0-2 (super)
((y))
(:metaclass computed-class*))
(defclass level1-1 (level0-1)
((z)))
(defclass sub (level1-1 level0-2)
((b
:accessor b-of
:initform (compute-as 0))
(a
:accessor a-of
:initform (compute-as 1)))
(:metaclass computed-class*))
(let ((sub (make-instance 'sub)))
(is (= (a-of sub) 1))
(is (= (b-of sub) 0))))
(defclass computed-test ()
((slot-a
:accessor slot-a-of
:initarg :slot-a
:computed-in compute-as)
(slot-b
:accessor slot-b-of
:initarg :slot-b
:computed-in compute-as))
(:metaclass computed-class*))
(deftest boundp1 ()
(let ((object (make-instance 'computed-test)))
(signals unbound-slot (slot-a-of object))
(setf (slot-a-of object) (compute-as 1))
(setf (slot-b-of object) (compute-as (1+ (slot-a-of -self-))))
(is (= 2 (slot-b-of object)))
(setf (slot-a-of object) 2)
(is (= 2 (slot-a-of object)))
(is (= 3 (slot-b-of object)))
(slot-makunbound object 'slot-a)
(is (not (slot-boundp object 'slot-a)))
(signals unbound-slot (slot-a-of object))))
(deftest compute1 ()
(let ((object (make-instance 'computed-test
:slot-a (compute-as 1)
:slot-b (compute-as (1+ (slot-a-of -self-))))))
(is (= 1 (slot-a-of object)))
(is (= 2 (slot-b-of object)))
(setf (slot-a-of object) 2)
(is (= 2 (slot-a-of object)))
(is (= 3 (slot-b-of object)))))
(deftest compute2 ()
(let* ((object-1 (make-instance 'computed-test
:slot-a (compute-as 1)
:slot-b (compute-as (1+ (slot-a-of -self-)))))
(object-2 (make-instance 'computed-test
:slot-a (compute-as (+ (slot-a-of object-1) (slot-b-of object-1)))
:slot-b (compute-as (1+ (slot-a-of -self-))))))
(is (= 4 (slot-b-of object-2)))
(setf (slot-a-of object-1) 2)
(is (= 6 (slot-b-of object-2)))))
(deftest compute3 ()
(let* ((object-1 (make-instance 'computed-test
:slot-b (compute-as (1+ (slot-a-of -self-)))))
(object-2 (make-instance 'computed-test
:slot-a (compute-as (+ (slot-a-of object-1) (slot-b-of object-1)))
:slot-b (compute-as (1+ (slot-a-of -self-))))))
(signals unbound-slot (slot-a-of object-1))
(setf (slot-a-of object-1) 0)
(is (= 0 (slot-a-of object-1)))
(is (= 2 (slot-b-of object-2)))
(setf (slot-a-of object-1) 2)
(setf (slot-b-of object-2) (compute-as (* 2 (slot-a-of -self-))))
(is (= 5 (slot-a-of object-2)))
(is (= 10 (slot-b-of object-2)))))
(deftest compute4 ()
(setf (find-class 'sbcl-class-cache-computed-test) nil)
(defclass sbcl-class-cache-computed-test ()
((slot-a :accessor slot-a-of :initarg :slot-a)
(slot-b :accessor slot-b-of :initarg :slot-b))
(:metaclass computed-class*))
(let ((object (make-instance 'sbcl-class-cache-computed-test :slot-a (compute-as 1) :slot-b 1)))
(slot-a-of object)
(slot-b-of object))
(defclass sbcl-class-cache-computed-test ()
((slot-a :accessor slot-a-of :initarg :slot-a :computed-in compute-as)
(slot-b :accessor slot-b-of :initarg :slot-b :computed-in compute-as))
(:metaclass computed-class*))
(let ((object (make-instance 'sbcl-class-cache-computed-test
:slot-a (compute-as 1)
:slot-b (compute-as (1+ (slot-a-of -self-))))))
(is (= 1 (slot-a-of object)))
(is (= 2 (slot-b-of object)))
(setf (slot-a-of object) 2)
(is (= 3 (slot-b-of object)))))
(deftest reconfigure1 ()
(let* ((object (make-instance 'computed-test)))
(setf (slot-a-of object) nil)
(setf (slot-b-of object) nil)
(setf (slot-a-of object) (compute-as 1))
(setf (slot-b-of object) (compute-as (1+ (slot-a-of -self-))))
(is (= 2 (slot-b-of object)))
(setf (slot-a-of object) (compute-as (* 6 7)))
(is (= 43 (slot-b-of object)))
(setf (slot-a-of object) nil)
(is (null (slot-a-of object)))
(setf (slot-b-of object) (compute-as (not (slot-a-of -self-))))
(is (not (null (slot-b-of object))))))
(deftest reconfigure2 ()
(let ((object (make-instance 'computed-test)))
(flet ((current-pulse ()
(awhen (computed-state-or-nil object (find-slot (class-of object) 'slot-b))
(current-pulse it))))
(setf (slot-a-of object) 1)
(setf (slot-b-of object) (compute-as (1+ (slot-a-of object))))
(is (= 1 (slot-a-of object)))
(is (= 2 (slot-b-of object)))
(make-slot-uncomputed object 'slot-a)
(let ((pulse (current-pulse)))
(is (= 1 (slot-a-of object)))
(is (= 2 (slot-b-of object)))
(setf (slot-a-of object) 42)
(is (not (computed-state-p (standard-instance-access-form object (find-slot (class-of object) 'slot-a)))))
(is (= 2 (slot-b-of object)))
(is (= pulse (current-pulse)))
(setf (slot-a-of object) (compute-as 42)) (is (= (+ pulse 1) (current-pulse)))
(is (= 2 (slot-b-of object))) (invalidate-computed-slot object 'slot-b)
(is (= 43 (slot-b-of object)))))))
(deftest clet1 ()
(clet ((a (compute-as 1))
(b (compute-as (1+ a)))
(c (compute-as (+ a b))))
(is (eq 'variable (cs-kind a-state)))
(is (= c 3))
(setf a 2)
(is (= c 5))
(signals error (setf a (compute-as 42))) this (let ((old-a-state a-state))
(setf a-state (compute-as 42)) this (is (eq a-state old-a-state))) (is (= c 85))
(setf a 43)
(is (= c 87))))
(deftest clet2 ()
(clet ((a 42)
(b (compute-as (1+ a)))
(c (compute-as (1+ b))))
(locally (declare #+sbcl(sb-ext:muffle-conditions warning))
(signals unbound-variable (print a-state)))
(is (= a 42))
(is (= b 43))
(is (= c 44))
(setf a 2) (is (= a 2))
(is (= b 43))
(is (= c 44))
(invalidate-computed-state b-state)
(is (= b 3))
(is (= c 4))))
(deftest clet3 ()
(let (a-reader
a-writer
b-reader
b-writer
b-state-reader
c-reader)
(clet ((a 42)
(b (compute-as (1+ a)))
(c (compute-as (1+ b))))
(setf a-reader (lambda () a)
b-reader (lambda () b)
c-reader (lambda () c)
a-writer (lambda (value) (setf a value))
b-writer (lambda (value) (setf b value))
b-state-reader (lambda () b-state)))
(is (= (funcall a-reader) 42))
(is (= (funcall b-reader) 43))
(is (= (funcall c-reader) 44))
(funcall a-writer 2) (is (= (funcall a-reader) 2))
(is (= (funcall b-reader) 43))
(is (= (funcall c-reader) 44))
(invalidate-computed-state (funcall b-state-reader)) (is (= (funcall b-reader) 3))
(is (= (funcall c-reader) 4))))
(deftest clet4 ()
(clet ((a (compute-as 2))
(object (make-instance 'computed-test
:slot-a (compute-as (1+ a))
:slot-b (compute-as (1+ (slot-a-of -self-))))))
(is (= a 2))
(clet ((b (compute-as (+ a (slot-b-of object)))))
(is (= b 6))
(is (eq (cs-variable b-state) 'b))
(is (= (slot-a-of object) 3))
(is (= (slot-b-of object) 4))
(setf (slot-a-of object) 42)
(is (= a 2))
(is (= b 45))
(is (= (slot-a-of object) 42))
(is (= (slot-b-of object) 43)))))
isisisisisis
(deftest pulse1 ()
(let* ((object (make-instance 'computed-test
:slot-a (compute-as 1)
:slot-b (compute-as (1+ (slot-a-of -self-))))))
(flet ((current-pulse ()
(awhen (computed-state-or-nil object (find-slot (class-of object) 'slot-a))
(current-pulse it))))
(let ((pulse (current-pulse)))
(setf (slot-a-of object) 2)
(is (= (current-pulse) (+ 1 pulse)))
(slot-b-of object)
(is (= (current-pulse) (+ 1 pulse)))))))
(deftest circularity1 ()
(let* ((circularity #f)
(flag #f)
(object (make-instance 'computed-test
:slot-a (compute-as
(when (or circularity flag)
(slot-b-of -self-)))
:slot-b (compute-as
(when (or circularity (not flag))
(slot-a-of -self-))))))
(setf flag #f)
(invalidate-computed-slot object 'slot-a)
(invalidate-computed-slot object 'slot-b)
(is (null (slot-a-of object)))
(is (null (slot-b-of object)))
(setf flag #t)
(invalidate-computed-slot object 'slot-a)
(invalidate-computed-slot object 'slot-b)
(is (null (slot-a-of object)))
(is (null (slot-b-of object)))
(setf circularity #t)
(invalidate-computed-slot object 'slot-a)
(invalidate-computed-slot object 'slot-b)
(signals error (slot-a-of object))
(signals error (slot-b-of object))))
(deftest universe-separation1 ()
(clet ((a (compute-as 1))
(b (separated-compute-as (1+ a)))
(c (compute-as (+ a b))))
(is (= a 1))
(is (= c 3))
(setf a 42)
(is (= c 44))
(is (= 1 (length (cs-depends-on c-state))))
(is (= 0 (length (cs-depends-on b-state))))))
(clet ((words-to-be-uppercased (compute-as '()))
(integers-to-be-factorized (compute-as '()))
(irrelevant-variable (separated-compute-as nil))
(run-counter)
(memoize-table))
(setf memoize-table
(second (multiple-value-list
(defcfun (format* :computed-in compute-as) (datum &rest args)
(incf run-counter)
irrelevant-variable (labels ((factorial (n)
(cond ((= n 1) 1)
(t (* n (factorial (- n 1)))))))
(apply #'format nil datum
(loop for arg in args
collect (cond ((and (stringp arg)
(member arg words-to-be-uppercased :test #'string=))
(string-upcase arg))
((and (integerp arg)
(member arg integers-to-be-factorized :test #'eql))
(factorial arg))
(t arg)))))))))
(deftest (defcfun1 :compile-before-run #f) ()
(setf run-counter 0)
(setf words-to-be-uppercased '())
(setf integers-to-be-factorized '())
(let ((test-datum "~A-~A-~A")
(test-args (list "foo" "bar" 42)))
(macrolet ((is* (expected)
`(is (string= ,expected (apply 'format* test-datum test-args)))))
(is* "foo-bar-42")
(is (= run-counter 1))
(is* "foo-bar-42")
(is (= run-counter 1))
(setf irrelevant-variable 123)
(is* "foo-bar-42")
(is (= run-counter 1))
(push 1 integers-to-be-factorized)
(is* "foo-bar-42")
(is (= run-counter 2))
(is* "foo-bar-42")
(is (= run-counter 2))
(push "bar" words-to-be-uppercased)
(is* "foo-BAR-42")
(is (= run-counter 3))
(is* "foo-BAR-42")
(is (= run-counter 3))
(push 42 integers-to-be-factorized)
(is* "foo-BAR-1405006117752879898543142606244511569936384000000000")
(is (= run-counter 4))
(is* "foo-BAR-1405006117752879898543142606244511569936384000000000")
(is (= run-counter 4))
(dotimes (j 1000)
(dotimes (i 100)
(format* test-datum "foo" "bar" i)))
(is (= run-counter 103))
break (is (= (hash-table-count memoize-table) 100))))))
(defcfun (fun-with-multiple-values :computed-in compute-as) (some arg &key key)
(values key arg some))
(deftest defcfun2 ()
(is (equal (list 3 2 1) (multiple-value-list (fun-with-multiple-values 1 2 :key 3)))))
(defclass standard-test ()
((slot-a
:accessor slot-a-of
:initarg :slot-a
:initform 0)
(slot-b
:accessor slot-b-of
:initarg :slot-b
:initform 0)))
(deftest timing1 ()
(flet ((measure (object message)
(setf (slot-a-of object) 0)
#+sbcl(sb-ext:gc :full t)
(terpri *debug-io*)
(write-line message *debug-io*)
(terpri *debug-io*)
(time
(dotimes (counter 4000000)
(slot-b-of object)))
(terpri *debug-io*)))
(measure (make-instance 'standard-test) "*** Reader, no computation, standard accessor: ")
(measure (make-instance 'computed-test
:slot-a (compute-as 0)
:slot-b (compute-as (1+ (slot-a-of -self-))))
"*** Reader, no computation, computed accessor: ")))
(deftest timing2 ()
(flet ((measure (object message)
#+sbcl(sb-ext:gc :full t)
(terpri *debug-io*)
(write-line message *debug-io*)
(terpri *debug-io*)
(time
(dotimes (counter 1000000)
(setf (slot-a-of object) counter)
(slot-b-of object)))
(terpri *debug-io*)))
(measure (make-instance 'standard-test) "*** Reader, writer, no computation, standard accessor: ")
(measure (make-instance 'computed-test
:slot-a (compute-as 0)
:slot-b (compute-as (1+ (slot-a-of -self-))))
"*** Reader, writer, recomputation, computed accessor: ")))