Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
257 lines (223 sloc) 7.67 KB
;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*-
(defpackage #:let-plus-tests
(:use #:cl #:alexandria #:lift #:let-plus)
(:export #:run))
(in-package #:let-plus-tests)
(deftestsuite let-plus-tests () ())
(defun run ()
"Run all the tests for LET-PLUS."
(run-tests :suite 'let-plus-tests))
(defmacro test-r/o-and-r/w (init-form bindings r/o-form r/w-form
&key (add 7)
(modified-variable (caar bindings)))
"Macro for autogenerating tests for testing read-only and read-write access.
INIT-FORM is evaluated and bound to a value, which is then bound using LET+
with r/o-form (for read only access) and r/w-form for (read and write access).
Values are compared to bindings (which are of the form (VARIABLE VALUE), where
value should be numeric. MODIFIED-VARIABLE is modified, by adding ADD and
checked for consistency (r/o form should not modify value, while r/w form
should)."
(with-unique-names (object)
(once-only (add)
`(let ((,object ,init-form))
(let+ ((,r/o-form ,object))
,@(loop for (var value) in bindings
collect `(ensure-same ,var ,value))
(incf ,modified-variable ,add))
(let+ ((,r/w-form ,object))
,@(loop for (var value) in bindings
collect `(ensure-same ,var ,value))
(incf ,modified-variable ,add))
(let+ ((,r/o-form ,object))
(ensure-same ,(caar bindings) (+ ,add ,(cadar bindings))))))))
(addtest (let-plus-tests)
test-let*-compatibility
(let+ (a
(b 1)
(c (+ b 3)))
(ensure-same a nil)
(ensure-same b 1)
(ensure-same c 4)))
(addtest (let-plus-tests)
test-unrecognized-form
(ensure-warning (macroexpand '(let+ (((&does-not-exist a b) '(1 2 3)))))))
(defclass foo ()
((bar :accessor bar :initarg :bar)
(baz :accessor baz-acc :initarg :baz))
(:documentation "Class for testing purposes."))
(addtest (let-plus-tests)
test-slots
(test-r/o-and-r/w (make-instance 'foo :bar 1 :baz 2)
((bar 1) (baz2 2))
(&slots-r/o bar (baz2 baz))
(&slots bar (baz2 baz))))
(addtest (let-plus-tests)
test-accessors
(test-r/o-and-r/w (make-instance 'foo :bar 1 :baz 2)
((bar 1) (baz 2))
(&accessors-r/o bar (baz baz-acc))
(&accessors bar (baz baz-acc))))
(defstruct foo2
"Structure for testing purposes."
bar baz)
(addtest (let-plus-tests)
test-structure
(test-r/o-and-r/w (make-foo2 :bar 1 :baz 2)
((bar 1) (baz 2))
(&structure-r/o foo2- bar (baz baz))
(&structure foo2- bar (baz baz))))
(addtest (let-plus-tests)
test-values
(let+ (((&values a &ign c) (values 1 2 3)))
(ensure-same a 1)
(ensure-same c 3)))
(addtest (let-plus-tests)
test-values-recursive
(let+ (((&values (a b) &ign c) (values '(1 4) 2 3)))
(ensure-same a 1)
(ensure-same b 4)
(ensure-same c 3)))
(addtest (let-plus-tests)
test-array
(let+ ((#2A((a &ign) (b c)) #2A((1 2) (3 4))))
(ensure-same a 1)
(ensure-same b 3)
(ensure-same c 4))
(ensure-error (let+ ((#(a b c) #(1 2))))))
(addtest (let-plus-tests)
test-array-elements
(test-r/o-and-r/w (make-array '(2 2) :initial-contents '((1 2) (3 4)))
((a 1) (b 3) (c 4))
(&array-elements-r/o (a 0 0)
(b 1 0)
(c 1 1))
(&array-elements (a 0 0)
(b 1 0)
(c 1 1))))
(addtest (let-plus-tests)
test-flet
(let+ (((&flet add1 (x)
(1+ x)) ))
(ensure-same (add1 2) 3)))
(addtest (let-plus-tests)
test-labels
(let+ (((&labels my-factorial (x)
(if (<= 2 x)
(* x (my-factorial (1- x)))
1))))
(ensure-same (my-factorial 4) 24)))
(addtest (let-plus-tests)
test-labels/mutual-recursion
(let+ (((&labels my-even? (x)
(cond
((zerop x)
t)
((plusp x)
(my-odd? (1- x)))
(t
nil))))
((&labels my-odd? (x)
(my-even? (1- x)))))
(ensure-same (my-odd? 4) nil)
(ensure-same (my-even? 4) t)
(ensure-same (my-odd? 5) t)
(ensure-same (my-even? 5) nil)))
(addtest (let-plus-tests)
test-plist
(test-r/o-and-r/w (list 'a 1 :b 2 'c '3)
((a 1) (b 2) (c 3) (d 4))
(&plist-r/o a (b :b) (c nil) (d nil 4))
(&plist a (b :b) (c nil) (d nil 4))))
(addtest (let-plus-tests)
test-hash-table
(test-r/o-and-r/w (let ((table (make-hash-table)))
(setf (gethash 'a table) 1
(gethash :b table) 2
(gethash 'c table) 3)
table)
((a 1) (b 2) (c 3) (d 4))
(&hash-table-r/o a (b :b) (c nil) (d nil 4))
(&hash-table a (b :b) (c nil) (d nil 4))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defstruct ab
"A structure for testing defstruct+."
a b)
(define-structure-let+ (ab) a b))
(addtest (let-plus-tests)
test-defstruct+
(test-r/o-and-r/w (make-ab :a 3 :b 7)
((aa 3) (bb 7))
(&ab-r/o aa bb)
(&ab aa bb)))
(addtest (let-plus-tests)
test-fwrap
(let+ (((&fwrap add) (lambda (a b &key (c 0)) (+ a b c))))
(ensure-same (add 1 2) 3)
(ensure-same (add 1 2 :c 3) 6)))
(addtest (let-plus-tests)
test-flet+
(ensure-same (let+ (((&flet+ add3 (#(a b c))
(+ a b c))))
(add3 #(1 2 3)))
6))
(addtest (let-plus-tests)
test-labels+
(let+ (((&labels+ foo ((a . b))
(if a
(foo (cons (cdr a) (cons (car a) b)))
b))))
(ensure-same (foo '((1 2 3) . nil)) '(3 2 1)))
(ensure-no-warning
(compile nil '(lambda (x)
(let+ (((&labels+ foo (&ign)))) (foo x))))))
(addtest (let-plus-tests)
test-defun+
(defun+ foo ((a . b))
"bar"
(+ a b))
(ensure-same (foo '(1 . 2)) 3)
(ensure-same (documentation 'foo 'function) "bar" :test #'string=)
(let ((expansion (macroexpand-1
'(defun+ foo ((a . b))
"foo docstring"
(declare (type integer a b))
(+ a b)))))
(ensure-same 'defun (first expansion))
(ensure-same 'foo (second expansion))
(ensure-same "foo docstring" (fourth expansion))
(let ((let+-expansion (fifth expansion)))
(ensure-same 'let+ (first let+-expansion))
(ensure-same '(declare (type integer a b)) (third let+-expansion))
(ensure-same '(+ a b) (fourth let+-expansion)))))
(addtest (let-plus-tests)
test-&warning
(ensure-warning
(macroexpand '(let+ ((&foo 1)) &foo)))
(ensure-warning
(macroexpand '(let+ ((&foo)) &foo)))
(ensure-warning
(macroexpand '(let+ (&foo) &foo))))
(addtest (let-plus-tests)
test-empty-let+
(ensure-same (let+ nil 1) 1 :test #'eql))
(addtest (let-plus-tests)
test-recursive-let+
(ensure-same (let+ ((#((a . b)) (vector (cons 1 2))))
(values a b))
(values 1 2))
;; (ensure-same (let+ (((#(a) #(b c)) (cons #(1) #(2 3))))
;; (values a b c))
;; (values 1 2 3))
)
(addtest (let-plus-tests)
test-complex
(let ((c #C(3 5)))
(let+ (((&complex x y) c))
(ensure-same x 3)
(ensure-same y 5))))
(addtest (let-plus-tests)
test-nil
(ensure (let+ ((() '())) t))
(ensure-error (let+ ((() '(1)))))
;; (ensure-error (let+ ((() 1))))
)