misc-tests.lisp

(in-package #:polymorphic-functions)

(5am:def-suite static-dispatch :in :polymorphic-functions)
(5am:in-suite static-dispatch)

(defmacro define-compiled-function (name lambda-list &body body)
  #+sbcl
  `(defun ,name ,lambda-list ,@body)
  #-sbcl
  `(compile ',name '(lambda ,lambda-list ,@body)))

;; unwind-protect (apparantly) does not have an effect in the def-test forms below :/

(def-test required-args-correctness/static ()
  (ignoring-error-output
    (eval `(progn
             (define-polymorphic-function my= (a b) :overwrite t)
             (defpolymorph my= ((a string) (b string)) boolean
               (return-from my= (string= a b)))
             (defpolymorph my= ((a number) (b number)) boolean
               (= a b))
             (defpolymorph-compiler-macro my= (number number) (&whole form a b)
               (declare (ignore b))
               (if (and (numberp a) (= 0 a))
                   ''zero
                   form))
             ;; Fix ECL: 21.2.1 does not respect
             ;;   (locally (declare (optimize ...))
             ;;     ...)
             ;; In addition, implementations are free to avoid calling compiler-macro.
             ;; As far as ECL is concerned, it does call compiler-macro with COMPILE.
             ;; And even then, some issues prevail; for the time, just forget static dispatch
             ;; on "all" the implementations
             (define-compiled-function my=-caller ()
               (declare (optimize speed (debug 1)))
               (my= 0 5)))))
  (ignoring-error-output
    (eval `(let ((obj1 "hello")
                 (obj2 "world")
                 (obj3 "hello")
                 (obj4 5)
                 (obj5 5.0))
             (is (eq t   (my= obj1 obj3)))
             (is (eq nil (my= obj1 obj2)))
             (is (eq t   (my= obj4 obj5)))
             (is-error (my= obj1 obj4))
             #+(or sbcl ccl ecl cmucl)
             (is (eq 'zero (my=-caller))))))
  (undefine-polymorphic-function 'my=)
  (fmakunbound 'my=-caller))

(def-test optional-args-correctness/static ()
  (ignoring-error-output
    (eval `(progn                  ; This requires SBCL version 2.0.9+
             (define-polymorphic-function bar (a &optional b c) :overwrite t)
             (defpolymorph bar ((str string) &optional ((b integer) 5) ((c integer) 7)) t
               (list str b c))
             (defpolymorph-compiler-macro bar (string &optional integer integer)
                 (&whole form &rest args)
               (declare (ignore args))
               `(list ,form)) ; This usage of FORM also tests infinite recursion
             (define-compiled-function bar-caller ()
               (declare (optimize speed (debug 1)))
               (bar "hello" 9 7)))))
  (is (equal (eval `(bar "hello"))
             '("hello" 5 7)))
  (is (equal (eval `(bar "hello" 6))
             '("hello" 6 7)))
  (is (equal (eval `(bar "hello" 6 9))
             '("hello" 6 9)))
  #+(or sbcl ccl ecl cmucl)
  (is (equal (eval `(bar-caller))
             '(("hello" 9 7))))
  (undefine-polymorphic-function 'bar)
  (fmakunbound 'bar-caller))

(def-test typed-key-correctness/static ()
  (ignoring-error-output
    (eval `(progn
             (define-polymorphic-function foobar (a &key key b) :overwrite t)
             (defpolymorph foobar ((str string) &key ((key number) 5) ((b string) "world")) t
               (declare (ignore str))
               (list 'string key b))
             (defpolymorph foobar ((num number) &key ((key number) 6) ((b string) "world")) t
               (declare (ignore num))
               (list 'number key b))
             (defpolymorph-compiler-macro foobar (number &key (:key number) (:b string))
                 (&whole form &rest args)
               (declare (ignore args))
               `(list ,form))
             (define-compiled-function foobar-caller ()
               (declare (optimize speed (debug 1)))
               (foobar 7 :key 10 :b "world")))))
  (is (equal '(string 5 "world")    (eval `(foobar "hello"))))
  (is (equal '(string 5.6 "world")  (eval `(foobar "hello" :key 5.6))))
  (is (equal '(number 6 "world")    (eval `(foobar 5.6))))
  (is (equal '(number 9 "world")    (eval `(foobar 5.6 :key 9))))
  #+(or sbcl ccl cmucl) ; Fails on ECL for reasons I haven't debugged
  (is (equal '((number 10 "world")) (eval `(foobar-caller))))
  (is (equal '(number 6 "bye")      (eval `(foobar 5.6 :b "bye"))))
  (is (equal '(number 4.4 "bye")    (eval `(foobar 5.6 :b "bye" :key 4.4))))
  (undefine-polymorphic-function 'foobar)
  (fmakunbound 'foobar-caller))

(def-test recursively-unsafe/static ()
  (ignoring-error-output
    (eval `(progn
             (define-polymorphic-function foz (a) :overwrite t)
             (defpolymorph foz ((a number)) t
               (declare (optimize speed))
               (if (= a 5)
                   'number
                   (foz "hello")))
             (defpolymorph foz ((a string)) t
               (declare (optimize speed))
               (if (string= a "hello")
                   'string
                   (foz 5)))
             ;; Will result in infinite expansion upon redefinition,
             ;; if compilation is not done correctly
             (defpolymorph foz ((a number)) t
               (declare (optimize speed))
               (if (= a 5)
                   'number
                   (foz "hello"))))))
  (is (eq 'number (eval `(foz 5))))
  (is (eq 'string (eval `(foz "hello"))))
  (is (eq 'number (eval `(foz "world"))))
  (is (eq 'string (eval `(foz 7))))
  (undefine-polymorphic-function 'foz))

;;; FIXME: Add a test for recursive safety
;;; How to distinguish between runtime call vs compile time call?

(def-test rest-correctness-1/static ()
  (ignoring-error-output
    (eval `(define-polymorphic-function my+ (arg &rest args) :overwrite t))
    (eval `(progn
             (defpolymorph my+ ((num number) &rest numbers) number
               (if numbers
                   (+ num (apply 'my+ numbers))
                   num))
             (defpolymorph-compiler-macro my+ (number &rest) (&whole form &rest args)
               (declare (ignore args))
               `(list (+ ,@(cdr form))))
             (define-compiled-function my+-number-caller ()
               (declare (optimize speed (debug 1)))
               (my+ 3 2 8))
             (defpolymorph my+ ((l list) &rest lists) list
               (apply 'append l lists))
             (defpolymorph my+ ((str string) (num number) &key ((coerce t) nil)) string
               (if coerce
                   (uiop:strcat str (write-to-string num))
                   str)))))
  (is (eq 9 (eval `(my+ 2 3 4))))
  (is (equal '(1 2 3) (eval `(my+ '(1 2) '(3)))))
  #+(or sbcl ccl ecl cmucl)
  (is (equal '(13) (eval `(my+-number-caller))))
  (is (string= "hello5" (eval `(my+ "hello" 5 :coerce t))))
  (undefine-polymorphic-function 'my+)
  (fmakunbound 'my+-number-caller))

(def-test rest-correctness-2/static ()
  (ignoring-error-output
    (unwind-protect
         (progn
           (eval
            `(progn
               (define-polymorphic-function rest-tester (a &rest args) :overwrite t)
               (defpolymorph rest-tester ((a number) &key ((b number) 0)) number
                 (+ a b))
               (defpolymorph rest-tester ((a number) (b number) &key ((c number) 0)) number
                 (+ a b c)))))
      (is (= 4 (eval `(rest-tester 4))))
      (is (= 6 (eval `(rest-tester 4 :b 2))))
      (is (= 6 (eval `(rest-tester 4 2))))
      (is (= 8 (eval `(rest-tester 4 2 :c 2)))))))

#+sbcl
(def-test polymorph-sbcl-transforms ()
  (ignoring-error-output
    (eval `(progn
             (undefine-polymorphic-function 'sbcl-transform)
             (define-polymorphic-function sbcl-transform (a) :overwrite t)
             (defpolymorph sbcl-transform ((a array)) t
               (list 'array a))
             (defpolymorph sbcl-transform ((a string)) t
               (list 'string a))
             (defpolymorph-compiler-macro sbcl-transform (string) (&whole form a &environment env)
               `(list ',(form-type a env) ,form)))))
  (is (= 2 (length
            (sb-c::fun-info-transforms
             (sb-c::fun-info-or-lose 'sbcl-transform)))))
  (eval `(setf (compiler-macro-function 'sbcl-transform) nil))
  (ignoring-error-output
    (eval `(defun sbcl-transform-caller (b)
             (declare (optimize speed)
                      (type array b))
             (sbcl-transform b))))
  (is (equal '(array "string") (eval `(sbcl-transform-caller "string"))))
  (ignoring-error-output
    (eval `(defun sbcl-transform-compiler-macro-caller (b)
             (declare (optimize speed)
                      (type string b))
             (sbcl-transform b))))
  (is (equal '(string (string "string"))
             (eval `(sbcl-transform-compiler-macro-caller "string"))))
  (eval `(undefpolymorph 'sbcl-transform '(string)))
  (is (= 1 (length
            (sb-c::fun-info-transforms
             (sb-c::fun-info-or-lose 'sbcl-transform)))))
  (eval `(progn
           (undefine-polymorphic-function 'sbcl-transform)
           (fmakunbound 'sbcl-transform-caller)
           (fmakunbound 'sbcl-transform-compiler-macro-caller))))

#+sbcl
(def-test optional-sbcl-transforms ()
  (ignoring-error-output
    (eval `(progn
             (undefine-polymorphic-function 'optional-transforms)
             (define-polymorphic-function optional-transforms (a &optional b) :overwrite t)
             (defpolymorph optional-transforms ((a string) &optional ((b string) "")) t
               (list 'string a b))))
    (is (equal (eval `(let ((a "hello"))
                        (declare (optimize speed)
                                 (type string a))
                        (optional-transforms a)))
               (eval `(let ((a "hello"))
                        (declare (optimize speed))
                        (optional-transforms a)))))
    (is (equal (eval `(let ((a "hello"))
                        (declare (optimize speed)
                                 (type string a))
                        (optional-transforms a a)))
               (eval `(let ((a "hello"))
                        (declare (optimize speed))
                        (optional-transforms a a)))))
    (eval `(defpolymorph-compiler-macro optional-transforms (string &optional string)
               (&whole form &rest args)
             `(list (list ,@args) ,form)))
    (is (equal (eval `(let ((a "hello"))
                        (declare (optimize speed)
                                 (type string a))
                        (optional-transforms a)))
               (eval `(let ((a "hello"))
                        (declare (optimize speed))
                        (optional-transforms a)))))
    (is (equal (eval `(let ((a "hello"))
                        (declare (optimize speed)
                                 (type string a))
                        (optional-transforms a a)))
               (eval `(let ((a "hello"))
                        (declare (optimize speed))
                        (optional-transforms a a)))))
    (undefine-polymorphic-function 'optional-transforms)))

#+sbcl
(def-test key-sbcl-transforms ()
  (ignoring-error-output
    (eval `(progn
             (undefine-polymorphic-function 'key-transforms)
             (define-polymorphic-function key-transforms (a &key b) :overwrite t)
             (defpolymorph key-transforms ((a string) &key ((b string) "")) t
               (list 'string a b))))
    (is (equal (eval `(let ((a "hello"))
                        (declare (optimize speed)
                                 (type string a))
                        (key-transforms a)))
               (eval `(let ((a "hello"))
                        (declare (optimize speed))
                        (key-transforms a)))))
    (is (equal (eval `(let ((a "hello"))
                        (declare (optimize speed)
                                 (type string a))
                        (key-transforms a :b a)))
               (eval `(let ((a "hello"))
                        (declare (optimize speed))
                        (key-transforms a :b a)))))
    (eval `(defpolymorph-compiler-macro key-transforms (string &key (:b string))
               (&whole form &rest args)
             `(list (list ,@args) ,form)))
    (is (equal (eval `(let ((a "hello"))
                        (declare (optimize speed)
                                 (type string a))
                        (key-transforms a)))
               (eval `(let ((a "hello"))
                        (declare (optimize speed))
                        (key-transforms a)))))
    (is (equal (eval `(let ((a "hello"))
                        (declare (optimize speed)
                                 (type string a))
                        (key-transforms a :b a)))
               (eval `(let ((a "hello"))
                        (declare (optimize speed))
                        (key-transforms a :b a)))))
    (undefine-polymorphic-function 'key-transforms)))

#+sbcl
(def-test rest-sbcl-transforms ()
  (ignoring-error-output
    (eval `(progn
             (undefine-polymorphic-function 'rest-transforms)
             (define-polymorphic-function rest-transforms (a &rest args) :overwrite t)
             (defpolymorph rest-transforms ((s string) &rest args) t
               (list* 'string s args))))
    (is (equal (eval `(let ((a "hello"))
                        (declare (optimize speed)
                                 (type string a))
                        (rest-transforms a)))
               (eval `(let ((a "hello"))
                        (declare (optimize speed))
                        (rest-transforms a)))))
    (is (equal (eval `(let ((a "hello"))
                        (declare (optimize speed)
                                 (type string a))
                        (rest-transforms a a)))
               (eval `(let ((a "hello"))
                        (declare (optimize speed))
                        (rest-transforms a a)))))
    (eval `(defpolymorph-compiler-macro rest-transforms (string &rest) (&whole form &rest args)
             `(list (list ,@args) ,form)))
    (is (equal (eval `(let ((a "hello"))
                        (declare (optimize speed)
                                 (type string a))
                        (rest-transforms a)))
               (eval `(let ((a "hello"))
                        (declare (optimize speed))
                        (rest-transforms a)))))
    (is (equal (eval `(let ((a "hello"))
                        (declare (optimize speed)
                                 (type string a))
                        (rest-transforms a a)))
               (eval `(let ((a "hello"))
                        (declare (optimize speed))
                        (rest-transforms a a)))))
    (undefine-polymorphic-function 'rest-transforms)))

(def-test specialized-type-lists/static ()
  (ignoring-error-output
    (eval `(progn
             (undefine-polymorphic-function 'most-specialized-polymorph-tester)
             (define-polymorphic-function most-specialized-polymorph-tester (a))
             (defpolymorph most-specialized-polymorph-tester ((a string)) symbol
               (declare (ignorable a))
               'string)
             (defpolymorph-compiler-macro most-specialized-polymorph-tester (string) (a)
               (declare (ignorable a))
               `'(compiled string))
             (defpolymorph most-specialized-polymorph-tester ((a array)) symbol
               (declare (ignorable a))
               'array)
             (define-compiled-function most-specialized-polymorph-tester-caller ()
               (declare (optimize speed (debug 1)))
               (most-specialized-polymorph-tester "hello"))))
    (eval `(let ((a "string")
                 (b #(a r r a y)))
             (5am:is-true (eq 'string (most-specialized-polymorph-tester a)))
             (5am:is-true (eq 'array  (most-specialized-polymorph-tester b)))
             #+(or sbcl ccl ecl cmucl)
             (5am:is-true (equal '(compiled string)
                                 (most-specialized-polymorph-tester-caller)))))
    (eval `(undefine-polymorphic-function 'most-specialized-polymorph-tester))
    (eval `(fmakunbound 'most-specialized-polymorph-tester-caller))))

(def-test setf-polymorphs/static ()
  (ignoring-error-output
    (eval `(progn
             (define-polymorphic-function (setf foo) (a b) :overwrite t)
             (defpolymorph (setf foo) ((a number) (b number)) t
               (list a b))
             (defpolymorph-compiler-macro (setf foo) (number number) (a b)
               `(list 'compiler-macro ,a ,b))
             (define-compiled-function setf-foo-caller (a b)
               (declare (optimize speed (debug 1))
                        (type number a b))
               (funcall #'(setf foo) (the number (+ a b)) b))
             (define-compiled-function setf-foo-caller-direct (a b)
               (declare (optimize speed (debug 1))
                        (type number a b))
               (setf (foo b) (the number (+ a b)))))))
  (is (equal '(2 3) (eval '(funcall #'(setf foo) 2 3))))
  #+(or sbcl ccl)
  (is (equal '(compiler-macro 5 3) (eval `(setf-foo-caller 2 3))))
  ;; On SBCL this passed after incorporating compiler macro inside deftransform
  ;;   > Don't ask me why it works
  ;; On CCL, this works in the absence of EXTENSIBLE-COMPOUND-TYPES
  ;; because EXTENSIBLE-COMPOUND-TYPES wraps around CL-ENVIRONMENTS-CL,
  ;; which does not seem to propagate the declarations. FIXME: Debug this.
  (when (featurep `(:or :sbcl :ccl))
    (is (equal '(compiler-macro 5 3) (eval `(setf-foo-caller-direct 2 3)))))
  (fmakunbound 'setf-foo-caller)
  (fmakunbound 'setf-foo-caller-direct)
  (undefine-polymorphic-function '(setf foo)))


(def-test return-type-check/static ()
  (ignoring-error-output
    (eval `(progn
             (defun my-identity (x) x)
             (define-polymorphic-function foo (x) :overwrite t))))

  ;; Basic
  (5am:is-true (eval `(defpolymorph foo ((x string)) string x)))
  (5am:signals warning
    (eval `(defpolymorph foo ((x string)) number x)))
  (5am:is-true (eval `(defpolymorph foo ((x string)) string (my-identity x))))
  (5am:is-true (eval `(defpolymorph foo ((x string))
                          (values string number)
                        (values x 5 #\a))))

  ;; Optional
  (5am:is-true (eval `(defpolymorph foo ((x string))
                          (values string number &optional)
                        (values x 5))))
  (5am:signals warning
    (eval `(defpolymorph foo ((x string)) (values string number &optional)
             (values x 5 #\a))))

  ;; Rest
  (5am:signals warning
    (eval `(defpolymorph foo ((x string))
               (values string number &rest string)
             (values x 5 #\a))))
  (5am:is-true (eval `(defpolymorph foo ((x string))
                          (values string number &rest t)
                        (values x 5))))
  (5am:is-true (eval `(defpolymorph foo ((x string))
                          (values string number &rest t)
                        (values x 5 #\a))))

  ;; Optional and Rest
  (5am:is-true (eval `(defpolymorph foo ((x string))
                          (values string number &optional character &rest t)
                        (values x 5 #\a))))
  (5am:is-true (eval `(defpolymorph foo ((x string))
                          (values string number &optional character &rest t)
                        (values x 5))))
  (5am:is-true (eval `(defpolymorph foo ((x string))
                          (values string number &optional character &rest t)
                        (values x 5 #\a ""))))
  (5am:signals warning
    (eval `(defpolymorph foo ((x string)) (values string number &optional character &rest t)
             (values x))))

  (undefine-polymorphic-function 'foo)
  (fmakunbound 'my-identity))


(def-test subtype-polymorphism/static ()
  (unwind-protect
       (handler-bind ((warning #'muffle-warning))
         (eval `(progn
                  (define-polymorphic-function inner (a) :overwrite t)
                  (defpolymorph inner ((a string)) t
                    (declare (ignore a))
                    'string)
                  (defpolymorph inner ((a array)) t
                    (declare (ignore a))
                    'array)))

         (eval `(progn
                  (define-polymorphic-function outer (a) :overwrite t)
                  (defpolymorph (outer :inline t) ((a array)) t
                    (inner a))))
         (is (eq 'string (funcall (compile nil
                                           `(lambda (a)
                                              (declare (optimize speed (debug 1))
                                                       (type string a))
                                              (outer a)))
                                  "hello")))

         (eval `(defpolymorph (outer :inline t) ((a array)) t
                  (let ((b a))
                    (declare (type array b))
                    (inner b))))
         (is (eq 'array (funcall (compile nil
                                          `(lambda (a)
                                             (declare (optimize speed (debug 1))
                                                      (type string a))
                                             (outer a)))
                                 "hello")))
         ;; FIXME: Perhaps, this does not belong here:
         (eval `(defpolymorph (outer :inline t) ((a array)) t
                  (let ((b a))
                    (declare (type-like a b))
                    (inner b))))
         (is (eq 'string (funcall (compile nil
                                           '(lambda (a)
                                             (declare (optimize speed (debug 1))
                                              (type string a))
                                             (outer a)))
                                  "hello"))))

    (undefine-polymorphic-function 'inner)
    (undefine-polymorphic-function 'outer)
    (fmakunbound 'outer-caller)))