+cl-uffi (1.3.0-1) unstable; urgency=low
+
+ * Add initial support and tests for def-foreign-var
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Thu, 14 Aug 2003 15:38:33 -0600
+
cl-uffi (1.2.23-1) unstable; urgency=low
* New upstream with fixes suggested and patches submitted by Edi Weitz.
<refsynopsisdiv>
<title>Syntax</title>
<synopsis>
- <function>with-cast-pointer</function> <replaceable>binding-name ptr type & body body</replaceable> => <returnvalue>value</returnvalue>
+ <function>with-cast-pointer</function> (<replaceable>binding-name ptr type) & body body</replaceable> => <returnvalue>value</returnvalue>
</synopsis>
</refsynopsisdiv>
<refsect1>
<refsect1>
<title>Description</title>
<para>
- Executes BODY with POINTER casted to be a pointer to type TYPE. If
- BINDING-NAME is provided the casted pointer will be bound to this
+ Executes BODY with POINTER cast to be a pointer to type TYPE. If
+ BINDING-NAME is provided the cast pointer will be bound to this
name during the execution of BODY. If BINDING-NAME is not provided
POINTER must be a name bound to the pointer which should be
- casted. This name will be bound to the casted pointer during the
+ cast. This name will be bound to the cast pointer during the
execution of BODY.
This is a no-op in AllegroCL but will wrap BODY in a LET form if
DEREF-POINTER or DEREF-ARRAY.
</para>
</refsect1>
+ <refsect1>
+ <title>Examples</title>
+<programlisting>
+(with-foreign-object (size :int)
+ ;; FOO is a foreign function returning a :POINTER-VOID
+ (let ((memory (foo size)))
+ (when (mumble)
+ ;; at this point we know for some reason that MEMORY points
+ ;; to an array of unsigned bytes
+ (with-cast-pointer (memory :unsigned-byte)
+ (dotimes (i (deref-pointer size :int))
+ (do-something-with
+ (deref-array memory '(:array :unsigned-byte) i)))))))
+</programlisting>
+ </refsect1>
<refsect1>
<title>Side Effects</title>
<para>None.</para>
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: objects.lisp,v 1.16 2003/08/14 19:35:05 kevin Exp $
+;;;; $Id: objects.lisp,v 1.17 2003/08/14 21:40:13 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
'(error "WITH-CAST-POINTER not (yet) implemented for ~A"
(lisp-implementation-type)))
+(defmacro def-foreign-var (names type module)
+ #-lispworks (declare (ignore module))
+ (let ((foreign-name (if (atom names) names (first names)))
+ (lisp-name (if (atom names) (uffi::make-lisp-name names) (second names)))
+ (var-type (uffi::convert-from-uffi-type type :foreign-var)))
+ #+(or cmu scl)
+ `(alien:def-alien-variable (,foreign-name ,lisp-name) ,var-type)
+ #+sbcl
+ `(sb-alien:define-alien-variable (,foreign-name ,lisp-name) ,var-type)
+ #+allegro
+ `(ff:def-foreign-variable (,lisp-name ,foreign-name) :convention :c
+ :type ,var-type)
+ #+lispworks
+ (let ((temp-name (gensym)))
+ `(progn
+ (fli:define-foreign-variable (,temp-name ,foreign-name) :type ,var-type :module ,module)
+ (define-symbol-macro ,lisp-name (,temp-name))))
+ #-(or allegro cmu scl sbcl lispworks)
+ `(define-symbol-macro ,lisp-name
+ '(error "DEF-FOREIGN-VAR not (yet) defined for ~A"
+ (lisp-implementation-type)))))
#:+null-cstring-pointer+
#:char-array-to-pointer
#:with-cast-pointer
+ #:def-foreign-var
;; string functions
#:convert-from-cstring
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: primitives.lisp,v 1.9 2003/06/06 21:59:18 kevin Exp $
+;;;; $Id: primitives.lisp,v 1.10 2003/08/14 21:40:13 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar +type-conversion-hash+ (make-hash-table :size 20))
- #+(or cmu sbcl scl) (defvar *cmu-def-type-hash* (make-hash-table :size 20))
+ (defvar +type-conversion-hash+ (make-hash-table :size 20 :test #'eq))
+ #+(or cmu sbcl scl) (defvar *cmu-def-type-hash*
+ (make-hash-table :size 20 :test #'eq))
+ #+allegro (defvar *allegro-foreign-type-hash*
+ (make-hash-table :size 20 :test #'eq))
)
#+(or cmu sbcl scl)
-(defparameter *cmu-sbcl-def-type-list* nil)
+(defvar *cmu-sbcl-def-type-list* nil)
#+(or cmu scl)
-(defparameter *cmu-sbcl-def-type-list*
+(defvar *cmu-sbcl-def-type-list*
'((:char . (alien:signed 8))
(:unsigned-char . (alien:unsigned 8))
(:byte . (alien:signed 8))
)
"Conversions in CMUCL for def-foreign-type are different than in def-function")
#+sbcl
-(defparameter *cmu-sbcl-def-type-list*
+(defvar *cmu-sbcl-def-type-list*
'((:char . (sb-alien:signed 8))
(:unsigned-char . (sb-alien:unsigned 8))
(:byte . (sb-alien:signed 8))
)
"Conversions in SBCL for def-foreign-type are different than in def-function")
-(defparameter *type-conversion-list* nil)
+(defvar *type-conversion-list* nil)
#+(or cmu scl)
(setq *type-conversion-list*
(:float . :single-float) (:double . :double-float)
(:array . :array)))
+#+allegro
+(defvar *allegro-foreign-type-list*
+ '((:char . :signed-byte)
+ (:unsigned-char . :unsigned-byte)
+ (:byte . :signed-byte)
+ (:unsigned-byte . :unsigned-byte)
+ (:short . :signed-word)
+ (:unsigned-short . :unsigned-word)
+ (:int . :signed-long)
+ (:unsigned-int . :unsigned-long32)
+ (:long . :signed-long)
+ (:unsigned-long . :unsigned-long)
+ (:float . :single-float)
+ (:double . :double-float)
+ )
+ "Conversion for Allegro's system:memref function")
+
(dolist (type *type-conversion-list*)
(setf (gethash (car type) +type-conversion-hash+) (cdr type)))
(dolist (type *cmu-sbcl-def-type-list*)
(setf (gethash (car type) *cmu-def-type-hash*) (cdr type)))
+#+allegro
+(dolist (type *allegro-foreign-type-list*)
+ (setf (gethash (car type) *allegro-foreign-type-hash*) (cdr type)))
+
+(defun foreign-var-type-convert (type)
+ #+allegro (gethash type *allegro-foreign-type-hash*))
+
+
(defun basic-convert-from-uffi-type (type)
(let ((found-type (gethash type +type-conversion-hash+)))
(if found-type
(basic-convert-from-uffi-type :cstring-returning))
#+(and mcl (not openmcl))
((and (eq type :void) (eq context :return)) nil)
+ #+allegro
+ ((eq context :foreign-var)
+ (foreign-var-type-convert type))
(t
(basic-convert-from-uffi-type type)))
(let ((sub-type (car type)))
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: casts
+;;;; Name: casts.lisp
;;;; Purpose: Tests of with-cast-pointer
;;;; Programmer: Kevin M. Rosenberg / Edi Weitz
;;;; Date Started: Aug 2003
;;;;
-;;;; $Id: casts.lisp,v 1.1 2003/08/14 19:35:05 kevin Exp $
+;;;; $Id: casts.lisp,v 1.2 2003/08/14 21:40:13 kevin Exp $
;;;;
;;;; *************************************************************************
;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: foreign-loader.lisp,v 1.4 2003/08/13 18:53:42 kevin Exp $
+;;;; $Id: foreign-loader.lisp,v 1.5 2003/08/14 21:40:13 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(list
(pathname-directory *load-truename*)
"/usr/lib/uffi/"))
- :supporting-libraries '("c"))
+ :supporting-libraries '("c")
+ :module "uffi_tests")
(warn "Unable to load uffi-c-test-lib library"))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: foreign-var
+;;;; Purpose: Tests of foreign variables
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2003
+;;;;
+;;;; $Id: foreign-var.lisp,v 1.1 2003/08/14 21:40:13 kevin Exp $
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(def-foreign-var "uchar_13" :char "uffi_tests")
+(def-foreign-var "schar_neg_120" :char "uffi_tests")
+(def-foreign-var "uword_257" :unsigned-short "uffi_tests")
+(def-foreign-var "sword_neg_321" :short "uffi_tests")
+(def-foreign-var "uint_1234567" :int "uffi_tests")
+(def-foreign-var "sint_neg_123456" :int "uffi_tests")
+(def-foreign-var "float_neg_4_5" :float "uffi_tests")
+(def-foreign-var "double_3_1" :double "uffi_tests")
+
+(deftest fvar.1 uchar-13 13)
+(deftest fvar.2 schar-neg-120 -120)
+(deftest fvar.3 uword-257 257)
+(deftest fvar.4 sword-neg-321 -321)
+(deftest fvar.5 uint-1234567 1234567)
+(deftest fvar.6 sint-neg-123456 -123456)
+(deftest fvar.7 float-neg-4-5 -4.5f0)
+(deftest fvar.8 double-3-1 3.1d0)
+
+
* Programer: Kevin M. Rosenberg
* Date Started: Mar 2002
*
- * CVS Id: $Id: uffi-c-test-lib.c,v 1.2 2003/08/14 19:35:05 kevin Exp $
+ * CVS Id: $Id: uffi-c-test-lib.c,v 1.3 2003/08/14 21:40:13 kevin Exp $
*
* This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
*
#include <math.h>
+DLLEXPORT unsigned char uchar_13 = 13;
+DLLEXPORT signed char schar_neg_120 = -120;
+DLLEXPORT unsigned short uword_257 = 257;
+DLLEXPORT signed short sword_neg_321 = -321;
+DLLEXPORT unsigned int uint_1234567 = 1234567;
+DLLEXPORT signed int sint_neg_123456 = -123456;
+DLLEXPORT double double_3_1 = 3.1;
+DLLEXPORT float float_neg_4_5 = -4.5;
+
/* Test of constant input string */
DLLEXPORT
int
;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Apr 2003
;;;;
-;;;; $Id: uffi-tests.asd,v 1.9 2003/08/14 19:35:05 kevin Exp $
+;;;; $Id: uffi-tests.asd,v 1.10 2003/08/14 21:40:13 kevin Exp $
;;;; *************************************************************************
(defpackage #:uffi-tests-system
(:file "uffi-c-test-lib" :depends-on ("foreign-loader"))
(:file "compress" :depends-on ("foreign-loader"))
(:file "casts" :depends-on ("foreign-loader"))
+ (:file "foreign-var" :depends-on ("foreign-loader"))
))))
(defmethod perform ((o test-op) (c (eql (find-system :uffi-tests))))
projects / uffi.git / commitdiff