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

(load "../unit/unit-tester.lisp")
(load "dlambda.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))