qa-libc-libffi

#!/usr/bin/env newlisp

; Test libffi routines - all of the tests are performed using only the
; OS platforms libc system library. For tests compiling a C libray
; with source code in util/ffitest.c see qa-libffi

; some simple libc functions

; when doing "make testall" only text lines starting with ">>>" are printed

(set-locale "C")

(when (zero? (& 1024 (sys-info -1)))
    (println ">>>>> qa-libc-libffi: tests only run on extended FFI enabled versions compiled with ffilib")
    (exit))

(set 'is64bit (not (zero? (& 256 (sys-info -1))))) ; used later

(define (get-libc-name)
    (letn (libc-name (first (exec "cc -print-file-name=libc.so"))
           libc-filetype (first (exec (string "file -b " libc-name))))
       (if (find "ASCII" libc-filetype)
           (first (regex "[^ \t]+/libc\\.so\\.*[0-9]*" (read-file libc-name)))
           libc-name))
)

(define LIBC
  (case ostype
    ("Windows" "msvcrt.dll")
    ("Cygwin" "msvcrt.dll")
    ("OSX" "libc.dylib")
    ("BSD" (get-libc-name) )
    ("Linux" (get-libc-name) )
    ))

(println "\nTesting imports from " LIBC "\n")

(unless (catch (import LIBC "sprintf" "int" "char*" "char*" "int" "double") 'result)
    (println ">>>>> ERR cannot find library in qa-libc-libffi")
    (exit))

(set 'buff (dup "\000" 64))
(sprintf buff "int 42 => %i, double Pi => %6.4f" 42 (mul 2 (acos 0))) 
(set 'buff (get-string buff)) ;; trim buff of trailing zeroes
(println "->" buff "<-")
(unless (= buff "int 42 => 42, double Pi => 3.1416")
    (println ">>>>> ERR problem importing sprinf() in qa-libc-libffi"))

(import LIBC "atof" "double" "char*")
(println {(atof "3.141") => } (atof "3.141"))
(unless (= (atof "3.141") 3.141)
    (println ">>>>> ERR problem importing atof() in qa-libc-libffi"))

(import LIBC "atoi" "int" "char*")
(println {(atoi "3434") => } (atoi "3434"))
(unless (= (atoi "3434") 3434)
    (println ">>>>> ERR problem importing atoi() in qa-libc-libffi"))

(import LIBC "strcpy" "char*" "char*" "char*")
(set 'from "Hello World")
(set 'to (dup "\000" (length from)))
(strcpy to from)
(println "(strcpy from to) => " to)
(unless (= to from)
    (println ">>>>> ERR problem importing strcpy() in qa-libc-libffi"))

(when (!= ostype "Linux")
    (import LIBC "fabs" "double" "double")
    (println {(fabs -8.230) => } (fabs 8.230))
    (println {(fabs 3.14159) => } (fabs 3.14159))
    (unless (and (= (fabs -8.230) 8.230) (= (fabs 3.14159) 3.14159))
        (println ">>>>> ERR problem importing fabs() in qa-libc-libffi"))
)

; test struct pack unpack

(import LIBC "asctime" "char*" "void*")
(import LIBC "localtime" "void*" "void*")

(if (find ostype '("Windows"))
	(struct 'tm "int" "int" "int" "int" "int" "int" "int" "int" "int")
	(struct 'tm "int" "int" "int" "int" "int" "int" "int" "int" "int" "long" "char*")
)

(if (find ostype '("Windows" "Cygwin"))
    (set 'tmlist '(1 2 3 4 5 6 7 8 9))
    (set 'tmlist '(1 2 3 4 5 6 7 8 9 10 "hello world")))

(if (= tmlist (unpack tm (pack tm tmlist)))
    (println "unpack pack => true")
    (println ">>>>> ERR problem in struct pack/unpack in qa-libc-libffi"))

(set 'ptr (localtime (address (date-value))))
(println "unpack localtime structure => " (unpack tm ptr))
(println "struct testing, today => " (asctime (localtime (address (date-value)))))

; test callback

(import LIBC "qsort" "void" "void*" "int" "int" "void*")
(set 'len 1000)
(set 'rlist (rand 10 len))
(set 'carray (pack (dup "ld " len) rlist))
(define (cmp a b) (- (get-int a) (get-int b)))
(qsort (address carray) len 4 (callback 'cmp "int" "void*" "void*"))
(println "qsort " len " elements => " (apply <= (unpack (dup "ld " len) carray)))
(unless (apply <= (unpack (dup "ld " len) carray))
    (println ">>>>> ERR problem in import qsort() with callback in qa-libc-libffi"))


(unless (= ostype "Linux")
    (import LIBC "atexit" "void" "void*")
    (define (quit) (println "-> Quit ! => true"))
    (print "atexit callback => ")
    (atexit (callback 'quit "void" "void"))
)

(exit)