;; Tests for typed calling convention.

(in-package :cl-user)

(eval-when (:compile-toplevel)
  (fmakunbound '(:typed-entry-point fid))
  (fmakunbound '(:typed-entry-point sum-prod))
  (fmakunbound '(:typed-entry-point cons-sum))
  (fmakunbound '(:typed-entry-point id)))

;; First we create a declaration
(declaim (ftype (function (double-float) double-float)
		(:typed-entry-point fid)))

;; then the typed entry point
(defun (:typed-entry-point fid) (f) f)

;; then the "normal" entry point, which calls the typed version.
(defun fid (f)
  (%typed-call '(:typed-entry-point fid :adapt nil) f))

;; and also a compiler macro so that named calls automtomatically call
;; the typed entry point.
(define-compiler-macro fid (f)
  `(%typed-call '(:typed-entry-point fid :adapt t) ,f))

(defun test-fid-1 ()
  (assert (= (fid 1d0) 1d0)))

;; (fid 1d0)
;; (disassemble '(:typed-entry-point fid))
;; (disassemble 'fid)

;; Let's wrap that up as macro.  In a more polished implementation
;; DEFUN could do all this.
(defmacro defun-typed (name (&rest args) ((&rest arg-types) return-type) 
		       &body body)
  `(progn
     (declaim (ftype (function ,arg-types ,return-type)
		     (:typed-entry-point ,name)))
     (defun (:typed-entry-point ,name) ,args
       (the ,return-type
	 . ,body))
     (defun ,name ,args
       (%typed-call '(:typed-entry-point ,name :adapt nil) . ,args))
     (define-compiler-macro ,name ,args
       `(%typed-call '(:typed-entry-point ,',name :adapt t)
		     . ,(list . ,args)))))
				
(defun-typed f+ (x y)
    ((double-float double-float) double-float)
  (+ x y))

;; (disassemble '(:typed-entry-point f+))

(defun-typed sum-prod (x y z u v w)
    ((double-float double-float double-float
		   double-float double-float double-float)
     (values double-float double-float))
  (values (+ x y z u v w)
	  (* x y z u v w)))

;; (disassemble '(:typed-entry-point sum-prod))
;; (ext:info function linkage '(:typed-entry-point sum-prod))

(defun test-sum-prod-1 ()
  (multiple-value-bind (sum prod) (sum-prod 2d0 3d0 4d0 5d0 6d0 7d0)
    (assert (= sum (+ 2d0 3d0 4d0 5d0 6d0 7d0)))
    (assert (= prod (* 2d0 3d0 4d0 5d0 6d0 7d0)))))

(defun test-sum-prod-2 ()
  (multiple-value-bind (sum) (sum-prod 2d0 3d0 4d0 5d0 6d0 7d0)
    (assert (= sum (+ 2d0 3d0 4d0 5d0 6d0 7d0)))))

(defun test-sum-prod-3-aux (x y z u v w)
  (sum-prod x y z u v w))

(defun test-sum-prod-3 ()
  (multiple-value-bind (sum prod) (test-sum-prod-3-aux 2d0 3d0 4d0 5d0 6d0 7d0)
    (assert (= sum (+ 2d0 3d0 4d0 5d0 6d0 7d0)))
    (assert (= prod (* 2d0 3d0 4d0 5d0 6d0 7d0)))))

(defun-typed id (x)
    ((t) t)
  x)

;; (id 1)

(defun test-id-1 ()
  (assert (eql (id 1) 1)))

(defun test-id-2 ()
  (assert (eql (id 1d0) 1d0)))

;; This one has both boxed and unboxed arguments.
(defun-typed cons-sum (o1 f1 o2 f2)
    ((t double-float t double-float)
     (values cons double-float))
  (values (cons o1 o2) (+ f1 f2)))

(defun test-cons-sum-1 ()
  (multiple-value-bind (cons sum) (cons-sum 1 2d0 3 4d0)
    (assert (equal cons '(1 . 3)))
    (assert (= sum (+ 2d0 4d0)))))

;; SUM will be redefined with different types to exercise the linker a
;; bit.
(defun-typed sum (f1 f2)
    ((double-float double-float) double-float)
  (+ f1 f2))

(defun test-sum-1 ()
  (assert (= (sum 2d0 3d0) 5d0)))

(defun-typed sum (f1 f2)
    ((t t) t)
  (+ f1 f2))

(defun test-sum-2 ()
  (assert (= (sum 2d0 3d0) 5d0)))

(defun test-sum-3 ()
  (handler-case (progn (sum 2 3)
		       (assert nil))
    (type-error (c) 
      (assert (equal (type-error-datum c) 3))
      (assert (eq (type-error-expected-type c) 'double-float)))))

(defun-typed sum (f1 f2)
    ((t double-float) double-float)
  (+ f1 f2))

(defun test-sum-4 ()
  (assert (= (sum 2d0 3d0) 5d0)))

(defun test-sum-5 ()
  (assert (= (sum 2 3d0) 5d0)))

(defun test-sum-6 ()
  (handler-case (progn 
		  (sum #c(0 1) 3d0) 
		  (assert nil))
    (type-error (c)
      (assert (equal (type-error-datum c) #c(3d0 1d0)))
      (assert (eq (type-error-expected-type c) 'double-float)))))
      
#+(or)
(defun foo ()
  (labels ((sum (x y) (+ x y)))
    (declare (ftype (function (double-float double-float) double-float) sum))
    (list (sum 2d0 4d0)
	  (sum 2 4))))

(defun tests ()
  (test-fid-1)
  (test-sum-prod-1)
  (test-sum-prod-2)
  (test-sum-prod-3)
  (test-id-1)
  (test-id-2)
  (test-cons-sum-1)
  (test-sum-1)
  (test-sum-2)
  (test-sum-3)
  (test-sum-4)
  (test-sum-5)
  (test-sum-6)
  )

;; (tests)
