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

(load "../unit/unit-test.lisp")
(load "dlambda.lisp")

(defun test-dlambda ()

  (unit
    (list

      (defun empty-dlambda ()
        (assert-equal
         '(lambda (&rest arguments) (case (first arguments)))

          (dlambda)))

      (defun dlambda-default-method-only ()
        (assert-equal
         '(lambda (&rest arguments)
            (case (first arguments)
              (t (apply (lambda () (print "nothing")) arguments))))

          (dlambda
            (t () (print "nothing")))))

      (defun dlambda-named-method-only ()
        (assert-equal
         '(lambda (&rest arguments)
            (case (first arguments)
              (:write (apply (lambda () (print "something")) (rest arguments)))))

          (dlambda
            (:write () (print "something")))))

      (defun dlambda-named-and-default-method ()
        (assert-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 ()
        (assert-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 ()
        (assert-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))))))))