transcendental-lisp/lisp/lang/dlambda-test.lisp

97 lines
3.2 KiB
Common Lisp

(load "../unit/unit-tester.lisp")
(setq assertions (unit-tester-assertions))
(setq tests
(let ((arguments (gensym)))
(list
(defun empty-dlambda ()
(call assertions :assert-gensym-equal
`(lambda (&rest ,arguments) (case (first ,arguments)))
(dlambda)))
(defun dlambda-default-method-only ()
(call assertions :assert-gensym-equal
`(lambda (&rest ,arguments)
(case (first ,arguments)
(t (apply (lambda () (print "nothing")) ,arguments))))
(dlambda
(t () (print "nothing")))))
(defun dlambda-named-method-only ()
(call assertions :assert-gensym-equal
`(lambda (&rest ,arguments)
(case (first ,arguments)
(:write (apply (lambda () (print "something")) (rest ,arguments)))))
(dlambda
(:write () (print "something")))))
(defun dlambda-many-named-methods ()
(call assertions :assert-gensym-equal
`(lambda (&rest ,arguments)
(case (first ,arguments)
(:write1 (apply (lambda () (print "something")) (rest ,arguments)))
(:write2 (apply (lambda () (print "something")) (rest ,arguments)))
(:write3 (apply (lambda () (print "something")) (rest ,arguments)))))
(dlambda
(:write1 () (print "something"))
(:write2 () (print "something"))
(:write3 () (print "something")))))
(defun dlambda-named-and-default-method ()
(call assertions :assert-gensym-equal
`(lambda (&rest ,arguments)
(case (first ,arguments)
(:write (apply (lambda () (print "something")) (rest ,arguments)))
(t (apply (lambda () (print "nothing")) ,arguments))))
(dlambda
(:write () (print "something"))
(t () (print "nothing")))))
(defun dlambda-methods-with-arguments ()
(call assertions :assert-gensym-equal
`(lambda (&rest ,arguments)
(case (first ,arguments)
(:write (apply (lambda (message) (print message)) (rest ,arguments)))
(t (apply (lambda (&rest messages) (print messages)) ,arguments))))
(dlambda
(:write (message) (print message))
(t (&rest messages) (print messages)))))
(defun dlambda-methods-with-multiple-arguments ()
(call assertions :assert-gensym-equal
`(lambda (&rest ,arguments)
(case (first ,arguments)
(:write
(apply
(lambda (message &rest other-stuff)
(print message)
(print other-stuff))
(rest ,arguments)))
(t
(apply
(lambda (message1 message2 &rest other-stuff)
(print message1)
(print message2)
(print other-stuff))
,arguments))))
(dlambda
(:write (message &rest other-stuff)
(print message)
(print other-stuff))
(t (message1 message2 &rest other-stuff)
(print message1)
(print message2)
(print other-stuff))))))))
(call (unit-tester tests))