290 lines
8.7 KiB
Common Lisp
290 lines
8.7 KiB
Common Lisp
;;; -*- 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)))
|
|
|
|
(declaim (notinline two-element-vector))
|
|
(defun two-element-vector ()
|
|
#(1 2))
|
|
|
|
(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) (two-element-vector))))))
|
|
|
|
(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)))
|
|
|
|
(defun labels-test-function ()
|
|
10)
|
|
|
|
(addtest (let-plus-tests)
|
|
test-labels/dont-splice
|
|
(ensure-same (let+ (((&labels foo () (labels-test-function))))
|
|
(labels ((labels-test-function () 5))
|
|
(labels-test-function))
|
|
(foo))
|
|
10)
|
|
(ensure-same (let+ (((&labels foo () (labels-test-function))))
|
|
(labels ((labels-test-function () 5))
|
|
(values (foo) (labels-test-function))))
|
|
(values 10 5))
|
|
(ensure-same (let+ (((&labels foo () (labels-test-function))))
|
|
(let+ (((&labels labels-test-function () 5)))
|
|
(values (foo) (labels-test-function))))
|
|
(values 10 5)))
|
|
|
|
(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))))
|
|
)
|
|
|
|
(addtest (let-plus-tests)
|
|
test-empty-let+-with-declaration
|
|
(ensure-same (let+ ()
|
|
(declare (optimize speed))
|
|
t)
|
|
t)
|
|
(ensure-same (let+ ((&ign 1))
|
|
(declare (optimize speed))
|
|
t)
|
|
t))
|