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

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

(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)))))))