Re: Status update: CMUCL port to Darwin/OS X

"Thomas F. Burdick" <tfb@xxxxxxxxxxxxxxxx> writes:

> When I get a chance to test this code a little better, I'm going to
> submit it to SBCL.  After that, I'll port the changes back to CMUCL if
> no one beats me to it :-)

Below are some test cases I used for the x86.  Not very extensive, but
a start.

Helmut.


(defpackage :callback-test
  (:use :cl :ext :alien :c-call)) ;;:callback))

(in-package :callback-test)

(defmacro call (cb (rtype &rest args) &rest values)
  `(alien-funcall (sap-alien (callback ,cb) (function ,rtype ,@args))
    ,@values))

(defvar *test-verbose* nil)

(setq *test-verbose* t)

(defmacro deftest (name definitions &body tests)  
  (let ((length (length tests)))
  `(progn
    ,@definitions
    (let* ((passed (+ ,@(loop for test in tests
                              collect `(if (ignore-errors ,test) 1 0))))
           (failed (- ,length passed)))
      (when *test-verbose*
        (format t "; ~A ~A.~%" ',name (if (zerop failed) "passed" "failed")))
      (values passed failed)))))

(defmacro testgroup (&body tests)
  (let ((passed (gensym (string :passed)))
        (failed (gensym (string :failed))))
    `(let ((,passed 0)
           (,failed 0))
      ,@(loop for test in tests
              collect `(multiple-value-bind (passed failed) ,test
                        (incf ,passed passed)
                        (incf ,failed failed)))
    (format t "
~3D test~:P.
~3D passed.
~3D failed.~%"
            (+ ,passed ,failed)
            ,passed 
            ,failed))))

(defmacro defcallback (&rest args) `(def-callback . ,args))

(defun run-tests ()
  (testgroup
   (deftest test1
       ((defcallback test1 (int) 23456))
     (= 23456 (call test1 (int))))

   (deftest test2
       ((defcallback test2 (void)
          23456))
     (null (multiple-value-list (call test2 (void)))))

   (deftest test3
       ((defcallback test3 (int (a1 int) (a2 int))
          (+ a1 a2)))
     (= 7 (call test3 (int int int)
                3 4)))

   (deftest test4
       ((defcallback test4 (long (a1 long) (a2 long))
          (+ a1 a2)))
     (= 7 (call test4 (long long long)
                3 4)))

   (deftest test5
       ((defcallback test5 (long (a1 long))
          a1))
     (= #x7fffffff (call test5 (long long) #x7fffffff))
     (= #x-7fffffff (call test5 (long long) #x-7fffffff)))

   (deftest test6
       ((defcallback test6 (unsigned-long (a1 unsigned-long))
          a1))
     (= #xffffffff (call test6 (unsigned-long unsigned-long) #xffffffff)))
  
   (deftest test7
       ((defcallback test7 (double (a1 double))
          a1))
     (= 0.0d0 (call test7 (double double) 0.0d0))
     (= 0.2d100 (call test7 (double double) 0.2d100))
     (= most-positive-double-float
        (call test7 (double double) most-positive-double-float))
     (= most-negative-double-float
        (call test7 (double double) most-negative-double-float)))

   (deftest test8
       ((defcallback test8 (float (a1 float))
          a1))
     (= 0.0 (call test8 (float float) 0.0))
     (= 0.1 (call test8 (float float) 0.1))
     (= most-positive-single-float (call test8 (float float) 
                                         most-positive-single-float))
     (= most-negative-single-float (call test8 (float float) 
                                         most-negative-single-float)))


   (deftest test9
       ((defcallback test9 (float (a1 float) (a2 float))
          a2))
     (= 0.1 (call test9 (float float float) 0.0 0.1))
     (= 0.0 (call test9 (float float float) 0.1 0.0))
     (= most-positive-single-float 
        (call test9 (float float float) 
              most-negative-single-float
              most-positive-single-float ))
     (= most-negative-single-float 
        (call test9 (float float float)
              most-positive-single-float
              most-negative-single-float)))

   (deftest test10
       ((defcallback test10 (double (a1 double) (a2 double))
          a2))
     (= 0.1d0 (call test10 (double double double) 0.0d0 0.1d0))
     (= 0.0d0 (call test10 (double double double) 0.1d0 0.0d0))
     (= most-positive-double-float 
        (call test10 (double double double) 
              most-negative-double-float
              most-positive-double-float ))
     (= most-negative-double-float 
        (call test10 (double double double)
              most-positive-double-float
              most-negative-double-float)))

   (deftest test11  
       ((defcallback test11 (char (a1 char) (a2 char))
          a2))
     (= -128 (call test11 (char char char) 127 -128))
     (= 127 (call test11 (char char char) -128 127)))

   (deftest test12
       ((defcallback test12 (unsigned-char (a1 unsigned-char) (a2 
unsigned-char))
          a2))
     (= 255 (call test12 (unsigned-char unsigned-char unsigned-char)
                  0 255))
     (= 0 (call test12 (unsigned-char unsigned-char unsigned-char) 255 0)))

   (deftest test13
       ((defcallback test13 ((signed 64) (a (signed 64)))
          a))
     (= #x7fffffffffffffff (call test13 ((signed 64) (signed 64))
                                 #x7fffffffffffffff))
     (= #x-7fffffffffffffff (call test13 ((signed 64) (signed 64))
                                  #x-7fffffffffffffff)))


   (deftest test14
       ((defcallback test14 ((signed 64) (a (signed 64)) (b (signed 64)))
          b))
     (= #x7fffffffffffffff (call test14 ((signed 64) 
                                         (signed 64) (signed 64))
                                 0
                                 #x7fffffffffffffff))
     (= 0 (call test14 ((signed 64) (signed 64) (signed 64))
                #x7fffffffffffffff 0)))
   (deftest  qsort
       ((def-alien-routine qsort void
          (base (* t))
          (nmemb int)
          (size int)
          (compar (* (function int (* t) (* t)))))
        (defcallback my< (int (arg1 (* double))
                              (arg2 (* double)))
          (gc)
          (let ((a1 (deref arg1))
                (a2 (deref arg2)))
            (cond ((= a1 a2)  0)
                  ((< a1 a2) -1)
                  (t         +1)))))
     (let* ((a (make-array 10 :element-type 'double-float
                           :initial-contents '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0
                                               2.5d0 0.0d0 0.1d0 0.2d0 0.3d0)))
            (copy (copy-seq a)))
       (qsort (sys:vector-sap a)
              (length a)
              (alien-size double :bytes)
              (callback my<))
       (equalp a (sort copy #'<))))
   ))

;; (disassem:disassemble-memory (callback my<) 50)

;; (sys:without-gcing (run-tests))

(run-tests)