uffi/tests uffi-c-test-lib.c,NONE,1.1 uffi-c-test-lib.lisp,NONE,1.1 Makefile,1.19,1.20 getenv.lisp,1.1,1.2 gethostname.lisp,1.3,1.4 union.lisp,1.3,1.4 c-test-fns.c,1.5,NONE c-test-fns.lisp,1.4,NONE file-socket.lisp,1.1,NONE getshells.lisp,1.1,NONE run-examples.lisp,1.1,NONE test-examples.lisp,1.1,NONE
"Kevin M. Rosenberg" <[email protected]> Tue, 29 Apr 2003 08:08:04 -0600
| Newsgroups | gmane.lisp.uffi.cvs |
|---|---|
| Message-ID | <[email protected]> |
Update of /pubcvs/uffi/tests
In directory boa.b9.com:/tmp/cvs-serv17013/tests
Modified Files:
Makefile getenv.lisp gethostname.lisp union.lisp
Added Files:
uffi-c-test-lib.c uffi-c-test-lib.lisp
Removed Files:
c-test-fns.c c-test-fns.lisp file-socket.lisp getshells.lisp
run-examples.lisp test-examples.lisp
Log Message:
--- NEW FILE: uffi-c-test-lib.c ---
/***************************************************************************
* FILE IDENTIFICATION
*
* Name: c-test-fns.c
* Purpose: Test functions in C for UFFI library
* Programer: Kevin M. Rosenberg
* Date Started: Mar 2002
*
* CVS Id: $Id: uffi-c-test-lib.c,v 1.1 2003/04/29 14:08:02 kevin Exp $
*
* This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
*
* UFFI users are granted the rights to distribute and use this software
* as governed by the terms of the Lisp Lesser GNU Public License
* (http://opensource.franz.com/preamble.html), also known as the LLGPL.
* These variables are correct for GCC
* you'll need to modify these for other compilers
***************************************************************************/
#ifdef WIN32
#include <windows.h>
BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll,
DWORD fdwReason,
LPVOID lpvReserved)
{
return 1;
}
#define DLLEXPORT __declspec(dllexport)
#else
#define DLLEXPORT
#endif
#include <ctype.h>
#include <stdlib.h>
#include <math.h>
/* Test of constant input string */
DLLEXPORT
int
cs_count_upper (char* psz)
{
int count = 0;
if (psz) {
while (*psz) {
if (isupper (*psz))
++count;
++psz;
}
return count;
} else
return -1;
}
/* Test of input and output of a string */
DLLEXPORT
void
cs_to_upper (char* psz)
{
if (psz) {
while (*psz) {
*psz = toupper (*psz);
++psz;
}
}
}
/* Test of an output only string */
DLLEXPORT
void
cs_make_random (int size, char* buffer)
{
int i;
for (i = 0; i < size; i++)
buffer[i] = 'A' + (rand() % 26);
}
/* Test of input/output vector */
DLLEXPORT
void
half_double_vector (int size, double* vec)
{
int i;
for (i = 0; i < size; i++)
vec[i] /= 2.;
}
--- NEW FILE: uffi-c-test-lib.lisp ---
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: c-test-fns.cl
;;;; Purpose: UFFI Example file for zlib compression
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
;;;; $Id: uffi-c-test-lib.lisp,v 1.1 2003/04/29 14:08:02 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; UFFI users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package :uffi-tests)
(unless (uffi:load-foreign-library
(uffi:find-foreign-library "uffi-c-test-lib"
(list *load-truename*
"/usr/lib/"))
:supporting-libraries '("c"))
(warn "Unable to load uffi-c-test-lib library"))
(uffi:def-function ("cs_to_upper" cs-to-upper)
((input (* :unsigned-char)))
:returning :void
)
(defun string-to-upper (str)
(uffi:with-foreign-string (str-foreign str)
(cs-to-upper str-foreign)
(uffi:convert-from-foreign-string str-foreign)))
(uffi:def-function ("cs_count_upper" cs-count-upper)
((input :cstring))
:returning :int
)
(defun string-count-upper (str)
(uffi:with-cstring (str-cstring str)
(cs-count-upper str-cstring)))
(uffi:def-function ("half_double_vector" half-double-vector)
((size :int)
(vec (* :double)))
:returning :void)
(uffi:def-constant +double-vec-length+ 10)
(defun test-half-double-vector ()
(let ((vec (uffi:allocate-foreign-object :double +double-vec-length+))
results)
(dotimes (i +double-vec-length+)
(setf (uffi:deref-array vec '(:array :double) i)
(coerce i 'double-float)))
(half-double-vector +double-vec-length+ vec)
(dotimes (i +double-vec-length+)
(push (uffi:deref-array vec '(:array :double) i) results))
(uffi:free-foreign-object vec)
(nreverse results)))
(defun t2 ()
(let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
(dotimes (i +double-vec-length+)
(setf (aref vec i) (coerce i 'double-float)))
(half-double-vector +double-vec-length+ vec)
vec))
#+(or cmu scl)
(defun t3 ()
(let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
(dotimes (i +double-vec-length+)
(setf (aref vec i) (coerce i 'double-float)))
(system:without-gcing
(half-double-vector +double-vec-length+ (system:vector-sap vec)))
vec))
(deftest c-test.1 (string-to-upper "this is a test") "THIS IS A TEST")
(deftest c-test.2 (string-to-upper nil) nil)
(deftest c-test.3 (string-count-upper "This is a Test") 2)
(deftest c-test.4 (string-count-upper nil) -1)
(deftest c-test.5 (test-half-double-vector)
(0.0d0 0.5d0 1.0d0 1.5d0 2.0d0 2.5d0 3.0d0 3.5d0 4.0d0 4.5d0))
Index: Makefile
===================================================================
RCS file: /pubcvs/uffi/tests/Makefile,v
retrieving revision 1.19
retrieving revision 1.20
diff -C2 -d -r1.19 -r1.20
*** Makefile 29 Apr 2003 12:42:03 -0000 1.19
--- Makefile 29 Apr 2003 14:08:02 -0000 1.20
***************
*** 22,26 ****
! base=c-test-fns
source=$(base).c
object=$(base).o
--- 22,26 ----
! base=uffi-c-test-lib
source=$(base).c
object=$(base).o
***************
*** 33,37 ****
gcc -fPIC -DPIC -c $(source) -o $(object)
gcc -shared $(object) -o $(shared_lib)
! #gcc -shared -Wl,-soname,c-test-fns $(object) -o $(shared_lib)
rm $(object)
--- 33,37 ----
gcc -fPIC -DPIC -c $(source) -o $(object)
gcc -shared $(object) -o $(shared_lib)
! #gcc -shared -Wl,-soname,uffi-c-test-lib $(object) -o $(shared_lib)
rm $(object)
Index: getenv.lisp
===================================================================
RCS file: /pubcvs/uffi/tests/getenv.lisp,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** getenv.lisp 30 Sep 2002 10:02:36 -0000 1.1
--- getenv.lisp 29 Apr 2003 14:08:02 -0000 1.2
***************
*** 17,21 ****
;;;; *************************************************************************
! (in-package :cl-user)
--- 17,21 ----
;;;; *************************************************************************
! (in-package :uffi-tests)
***************
*** 24,27 ****
--- 24,37 ----
:returning :cstring)
+ (uffi:def-function ("setenv" c-setenv)
+ ((name :cstring)
+ (value :cstring)
+ (overwrite :int))
+ :returning :int)
+
+ (uffi:def-function ("unsetenv" c-unsetenv)
+ ((name :cstring))
+ :returning :void)
+
(defun my-getenv (key)
"Returns an environment variable, or NIL if it does not exist"
***************
*** 29,47 ****
(uffi:with-cstring (key-native key)
(uffi:convert-from-cstring (c-getenv key-native))))
!
! #+examples-uffi
! (progn
! (flet ((print-results (str)
! (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
! (print-results "USER")
! (print-results "_FOO_")))
- #+test-uffi
- (progn
- (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
- (util.test:test (and (stringp (my-getenv "USER"))
- (< 0 (length (my-getenv "USER"))))
- t :fail-info "Error retrieving getenv")
- )
--- 39,64 ----
(uffi:with-cstring (key-native key)
(uffi:convert-from-cstring (c-getenv key-native))))
!
! (defun my-setenv (key name &optional (overwrite t))
! "Returns an environment variable, or NIL if it does not exist"
! (check-type key string)
! (check-type name string)
! (setq overwrite (if overwrite 1 0))
! (uffi:with-cstrings ((key-native key)
! (name-native name))
! (c-setenv key-native name-native (if overwrite 1 0))))
!
! (defun my-unsetenv (key)
! "Returns an environment variable, or NIL if it does not exist"
! (check-type key string)
! (uffi:with-cstrings ((key-native key))
! (c-unsetenv key-native)))
!
! (deftest getenv.1 (my-getenv "__UFFI_FOO1__") nil)
! (deftest setenv.1 (my-setenv "__UFFI_FOO1__" "UFFI-TEST") 0)
! (deftest getenv.2 (my-getenv "__UFFI_FOO1__") "UFFI-TEST")
! (deftest setenv.2 (my-unsetenv "__UFFI_FOO1__") nil)
! (deftest getenv.3 (my-getenv "__UFFI_FOO1__") nil)
Index: gethostname.lisp
===================================================================
RCS file: /pubcvs/uffi/tests/gethostname.lisp,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** gethostname.lisp 2 Dec 2002 13:21:43 -0000 1.3
--- gethostname.lisp 29 Apr 2003 14:08:02 -0000 1.4
***************
*** 17,21 ****
;;;; *************************************************************************
! (in-package :cl-user)
--- 17,21 ----
;;;; *************************************************************************
! (in-package :uffi-tests)
***************
*** 45,66 ****
(error "gethostname() failed."))))
! #+examples-uffi
! (progn
! (format t "~&Hostname (technique 1): ~A" (gethostname))
! (format t "~&Hostname (technique 2): ~A" (gethostname2)))
- #+test-uffi
- (progn
- (let ((hostname1 (gethostname))
- (hostname2 (gethostname2)))
-
- (util.test:test (and (stringp hostname1) (stringp hostname2)) t
- :fail-info "gethostname not string")
- (util.test:test (and (not (zerop (length hostname1)))
- (not (zerop (length hostname2)))) t
- :fail-info "gethostname length 0")
- (util.test:test (string= hostname1 hostname1) t
- :fail-info "gethostname techniques don't match"))
- )
--- 45,54 ----
(error "gethostname() failed."))))
! (deftest gethostname.1 (stringp (gethostname)) t)
! (deftest gethostname.2 (stringp (gethostname2)) t)
! (deftest gethostname.3 (plusp (length (gethostname))) t)
! (deftest gethostname.4 (plusp (length (gethostname2))) t)
! (deftest gethostname.5 (gethostname) #.(gethostname2))
Index: union.lisp
===================================================================
RCS file: /pubcvs/uffi/tests/union.lisp,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** union.lisp 9 Dec 2002 16:30:20 -0000 1.3
--- union.lisp 29 Apr 2003 14:08:02 -0000 1.4
***************
*** 17,21 ****
;;;; *************************************************************************
! (in-package :cl-user)
(uffi:def-union tunion1
--- 17,21 ----
;;;; *************************************************************************
! (in-package :uffi-tests)
(uffi:def-union tunion1
***************
*** 26,89 ****
(df :double))
! (defun run-union-1 ()
! (let ((u (uffi:allocate-foreign-object 'tunion1)))
! (setf (uffi:get-slot-value u 'tunion1 'uint)
! ;; little endian
! #-(or sparc sparc-v9 powerpc ppc big-endian)
(+ (* 1 (char-code #\A))
(* 256 (char-code #\B))
(* 65536 (char-code #\C))
! (* 16777216 255))
! ;; big endian
! #+(or sparc sparc-v9 powerpc ppc big-endian)
(+ (* 16777216 (char-code #\A))
(* 65536 (char-code #\B))
(* 256 (char-code #\C))
! (* 1 255)))
! (format *standard-output* "~&Should be #\A: ~S"
! (uffi:ensure-char-character
! (uffi:get-slot-value u 'tunion1 'char)))
! ;; (format *standard-output* "~&Should be negative number: ~D"
! ;; (uffi:get-slot-value u 'tunion1 'int))
! (format *standard-output* "~&Should be positive number: ~D"
! (uffi:get-slot-value u 'tunion1 'uint))
! (uffi:free-foreign-object u))
! (values))
! #+test-uffi
! (defun test-union-1 ()
! (let ((u (uffi:allocate-foreign-object 'tunion1)))
! (setf (uffi:get-slot-value u 'tunion1 'uint)
! #-(or sparc sparc-v9 powerpc ppc)
! (+ (* 1 (char-code #\A))
! (* 256 (char-code #\B))
! (* 65536 (char-code #\C))
! (* 16777216 128))
! #+(or sparc sparc-v9 powerpc ppc)
! (+ (* 16777216 (char-code #\A))
! (* 65536 (char-code #\B))
! (* 256 (char-code #\C))
! (* 1 128))) ;set signed bit
! (util.test:test (uffi:ensure-char-character
! (uffi:get-slot-value u 'tunion1 'char))
! #\A
! :test #'eql
! :fail-info "Error with union character")
! #-(or sparc sparc-v9 mcl)
! ;; (util.test:test (> 0 (uffi:get-slot-value u 'tunion1 'int))
! ;; t
! ;; :fail-info
! ;; "Error with negative int in union")
! (util.test:test (plusp (uffi:get-slot-value u 'tunion1 'uint))
! t
! :fail-info
! "Error with unsigned int in union")
! (uffi:free-foreign-object u))
! (values))
! #+examples-uffi
! (run-union-1)
! #+test-uffi
! (test-union-1)
--- 26,49 ----
(df :double))
! (defvar *u* (uffi:allocate-foreign-object 'tunion1))
! (setf (uffi:get-slot-value *u* 'tunion1 'uint)
! #-(or sparc sparc-v9 powerpc ppc)
(+ (* 1 (char-code #\A))
(* 256 (char-code #\B))
(* 65536 (char-code #\C))
! (* 16777216 128))
! #+(or sparc sparc-v9 powerpc ppc)
(+ (* 16777216 (char-code #\A))
(* 65536 (char-code #\B))
(* 256 (char-code #\C))
! (* 1 128)))
! (deftest union.1 (uffi:ensure-char-character
! (uffi:get-slot-value *u* 'tunion1 'char)) #\A)
! #-(or sparc sparc-v9 mcl)
! (deftest union.2 (plusp (uffi:get-slot-value *u* 'tunion1 'uint)) t)
! ;; (uffi:free-foreign-object u))
!
--- c-test-fns.c DELETED ---
--- c-test-fns.lisp DELETED ---
--- file-socket.lisp DELETED ---
--- getshells.lisp DELETED ---
--- run-examples.lisp DELETED ---
--- test-examples.lisp DELETED ---