* src/ref.sgml:
Updated def-array-pointer documentation
+
+ * src/primitives.cl:
+ Made results of def-constant equal those of cl:defconstant
+
+ * src/objects.cl:
+ Made type be evaluated for with-foreign-object and allocate-foreign-object
+
+ * VERSION:
+ Increase to 0.3.0 to coincide with the release of CLSQL.
21 Mar 2002
* Fixed problem with NULL foreign-strings with CMUCL
-- Cleanup whether types passed to functions are evaluated or not.
-At this point, I think types should always be evaluated. That means
-passing a quote character in front of non-keyword types. So
-:char and '(:array :char) is the way types should be specified.
-This may involve stripping the (quote ...) for some implementations
-like CMUCL which doesn't evaluate the type argument.
-
- Split implementation-dependent code into separate files in preparation
for MCL and CormanLisp ports.
# Programer: Kevin M. Rosenberg
# Date Started: Mar 2002
#
-# CVS Id: $Id: Makefile,v 1.8 2002/03/23 09:09:24 kevin Exp $
+# CVS Id: $Id: Makefile,v 1.9 2002/03/23 16:32:39 kevin Exp $
#
# This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
#
PSFILE=${DOCFILE_BASE}.ps
DVIFILE=${DOCFILE_BASE}.dvi
TMPFILES=${DOCFILE_BASE}.aux ${DOCFILE_BASE}.out ${DOCFILE_BASE}.log
+DOCFILES=$(shell echo *.sgml)
all: html pdf ps dvi
check:
$(CHECK)
-html: html/manual.htm
+html: html/book1.htm
-html/manual.htm: ${DOCFILE}
+html/book1.htm: ${DOCFILES}
$(CHECK)
- ( rm -rf html ; mkdir html; cd html ; jade -t sgml -c ../catalog -d ${DSSSL_HTML} ../${DOCFILE}; mv book1.htm manual.htm; cd ..)
+ ( rm -rf html ; mkdir html; cd html ; jade -t sgml -c ../catalog -d ${DSSSL_HTML} ../${DOCFILE}; cd ..)
tex: ${TEXFILE}
-${TEXFILE}: ${DOCFILE}
+${TEXFILE}: ${DOCFILES}
$(CHECK)
jade -t tex -c catalog -d ${DSSSL_PRINT} ${DOCFILE}
<varlistentry>
<term><parameter>type</parameter></term>
<listitem>
- <para>A unevaluated type of foreign object to allocate.
+ <para>The type of foreign object to allocate. This parameter is evaluated.
</para>
</listitem>
</varlistentry>
<title>Examples</title>
<programlisting>
(def-struct ab (a :int) (b :double))
-(allocate-foreign-object ab)
+(allocate-foreign-object 'ab)
=> #<ptr>
</programlisting>
</refsect1>
</refentry>
+ <refentry id="with-foreign-object">
+ <refnamediv>
+ <refname>with-foreign-object</refname>
+ <refpurpose>Wraps the allocation of a foreign object around a body of code.
+ </refpurpose>
+ <refclass>Macro</refclass>
+ </refnamediv>
+ <refsynopsisdiv>
+ <title>Syntax</title>
+ <synopsis>
+ <function>with-foreign-object</function> <replaceable>(var type) &body body</replaceable> => <returnvalue>form-return</returnvalue>
+ </synopsis>
+ </refsynopsisdiv>
+ <refsect1>
+ <title>Arguments and Values</title>
+ <variablelist>
+ <varlistentry>
+ <term><parameter>var</parameter></term>
+ <listitem>
+ <para>The variable name to bind.
+ </para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term><parameter>type</parameter></term>
+ <listitem>
+ <para>The type of foreign object to allocate. This parameter is evaluated.
+ </para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term><returnvalue>form-return</returnvalue></term>
+ <listitem>
+ <para>The result of evaluating the <parameter>body</parameter>.
+ </para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+ </refsect1>
+ <refsect1>
+ <title>Description</title>
+ <para>
+This function wraps the allocation, binding, and destruction of a foreign object.
+On &cmucl; and
+&lw; platforms the object is stack allocated for efficiency. Benchmarks show that &acl; performs
+much better with static allocation.
+ </para>
+ </refsect1>
+ <refsect1>
+ <title>Examples</title>
+ <programlisting>
+(defun gethostname2 ()
+ "Returns the hostname"
+ (uffi:with-foreign-object (name '(:array :unsigned-char 256))
+ (if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256))
+ (uffi:convert-from-foreign-string name)
+ (error "gethostname() failed."))))
+ </programlisting>
+ </refsect1>
+ <refsect1>
+ <title>Side Effects</title>
+ <para>None.</para>
+ </refsect1>
+ <refsect1>
+ <title>Affected by</title>
+ <para>None.</para>
+ </refsect1>
+ <refsect1>
+ <title>Exceptional Situations</title>
+ <para>None.</para>
+ </refsect1>
+ </refentry>
+
<refentry id="pointer-address">
<refnamediv>
<refname>pointer-address</refname>
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: arrays.cl,v 1.1 2002/03/21 07:56:45 kevin Exp $
+;;;; $Id: arrays.cl,v 1.2 2002/03/23 16:32:39 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(defun test-array-2d ()
"Tests 2d array"
- (let ((a (uffi:allocate-foreign-object (* :long) +row-length+)))
+ (let ((a (uffi:allocate-foreign-object '(* :long) +row-length+)))
(dotimes (r +row-length+)
(declare (fixnum r))
(setf (uffi:deref-array a '(:array (* :long)) r)
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: gethostname.cl,v 1.8 2002/03/22 20:51:08 kevin Exp $
+;;;; $Id: gethostname.cl,v 1.9 2002/03/23 16:32:39 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(defun gethostname2 ()
"Returns the hostname"
- (uffi:with-foreign-object (name (:array :unsigned-char 256))
+ (uffi:with-foreign-object (name '(:array :unsigned-char 256))
(if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256))
(uffi:convert-from-foreign-string name)
(error "gethostname() failed."))))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: gettime.cl,v 1.6 2002/03/14 21:03:12 kevin Exp $
+;;;; $Id: gettime.cl,v 1.7 2002/03/23 16:32:39 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(defun gettime ()
"Returns the local time"
- (let* ((time (uffi:allocate-foreign-object time-t)))
- (declare (type time-t time))
+ (uffi:with-foreign-object (time 'time-t)
+;; (declare (type time-t time))
(c-time time)
(let ((tm-ptr (the tm-pointer (c-localtime time))))
(declare (type tm-pointer tm-ptr))
(uffi:get-slot-value tm-ptr 'tm 'min)
(uffi:get-slot-value tm-ptr 'tm 'sec)
)))
- (uffi:free-foreign-object time)
- time-string))
- ))
+ time-string))))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: strtol.cl,v 1.11 2002/03/20 04:56:52 kevin Exp $
+;;;; $Id: strtol.cl,v 1.12 2002/03/23 16:32:39 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
their was no string at all, or an integer indicating position in string
of first non-valid character"
(let* ((str-native (uffi:convert-to-foreign-string str))
- (endptr (uffi:allocate-foreign-object char-ptr))
+ (endptr (uffi:allocate-foreign-object 'char-ptr))
(value (c-strtol str-native endptr base))
(endptr-value (uffi:deref-pointer endptr 'char-ptr)))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: union.cl,v 1.2 2002/03/21 08:30:10 kevin Exp $
+;;;; $Id: union.cl,v 1.3 2002/03/23 16:32:39 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(df :double))
(defun test-union-1 ()
- (let ((u (uffi:allocate-foreign-object tunion1)))
+ (let ((u (uffi:allocate-foreign-object 'tunion1)))
(setf (uffi:get-slot-value u 'tunion1 'uint)
(+ (char-code #\A)
(* 256 (char-code #\B))
(* 65536 (char-code #\C))
(* 16777216 255)))
- (format t "~&Should be #\A: ~S"
+ (format *standard-output* "~&Should be #\A: ~S"
(uffi:ensure-char-character
(uffi:get-slot-value u 'tunion1 'char)))
- (format t "~&Should be negative number: ~D"
+ (format *standard-output* "~&Should be negative number: ~D"
(uffi:get-slot-value u 'tunion1 'int))
- (format t "~&Should be positive number: ~D"
+ (format *standard-output* "~&Should be positive number: ~D"
(uffi:get-slot-value u 'tunion1 'uint))
(uffi:free-foreign-object u))
(values))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: objects.cl,v 1.14 2002/03/22 20:51:08 kevin Exp $
+;;;; $Id: objects.cl,v 1.15 2002/03/23 16:32:39 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(defmacro allocate-foreign-object (type &optional (size :unspecified))
"Allocates an instance of TYPE. If size is specified, then allocate
-an array of TYPE with size SIZE."
+an array of TYPE with size SIZE. The TYPE parameter is evaluated."
(if (eq size :unspecified)
(progn
#+cmu
- `(alien:make-alien ,(convert-from-uffi-type type :allocation))
+ `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
#+lispworks
- `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate))
+ `(fli:allocate-foreign-object :type ,(convert-from-uffi-type type :allocate))
#+allegro
- `(ff:allocate-fobject ',(convert-from-uffi-type type :allocate) :c))
+ `(ff:allocate-fobject ,(convert-from-uffi-type type :allocate) :c))
(progn
#+cmu
- `(alien:make-alien ,(convert-from-uffi-type type :allocation) ,size)
+ `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size)
#+lispworks
- `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate) :nelems ,size)
+ `(fli:allocate-foreign-object :type ,(convert-from-uffi-type type :allocate) :nelems ,size)
#+allegro
- `(ff:allocate-fobject '(:array ,(convert-from-uffi-type type :allocate) ,(eval size)) :c)
+ `(ff:allocate-fobject '(:array ,(convert-from-uffi-type (eval type) :allocate) ,(eval size)) :c)
)
))
obj
)
+;; TYPE is evaluated.
(defmacro with-foreign-object ((var type) &rest body)
#-(or cmu lispworks) ; default version
`(let ((,var (allocate-foreign-object ,type)))
(free-foreign-object ,var)))
#+cmu
(let ((obj (gensym)))
- `(alien:with-alien ((,obj ,(convert-from-uffi-type type :allocate)))
+ `(alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate)))
(let ((,var (alien:addr ,obj)))
,@body)))
#+lispworks
`(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type
- type :allocate)))
+ (eval type) :allocate)))
,@body)
)
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: primitives.cl,v 1.13 2002/03/23 09:32:43 kevin Exp $
+;;;; $Id: primitives.cl,v 1.14 2002/03/23 16:32:39 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
"Macro to define a constant and to export it"
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant ,name ,value)
- ,(if export (list 'export `(quote ,name)) (values))))
+ ,(when export (list 'export `(quote ,name)))
+ ',name))
(defmacro def-type (name type)
"Generates a (deftype) statement for CL. Currently, only CMUCL
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: arrays.cl,v 1.1 2002/03/21 07:56:45 kevin Exp $
+;;;; $Id: arrays.cl,v 1.2 2002/03/23 16:32:39 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(defun test-array-2d ()
"Tests 2d array"
- (let ((a (uffi:allocate-foreign-object (* :long) +row-length+)))
+ (let ((a (uffi:allocate-foreign-object '(* :long) +row-length+)))
(dotimes (r +row-length+)
(declare (fixnum r))
(setf (uffi:deref-array a '(:array (* :long)) r)
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: gethostname.cl,v 1.8 2002/03/22 20:51:08 kevin Exp $
+;;;; $Id: gethostname.cl,v 1.9 2002/03/23 16:32:39 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(defun gethostname2 ()
"Returns the hostname"
- (uffi:with-foreign-object (name (:array :unsigned-char 256))
+ (uffi:with-foreign-object (name '(:array :unsigned-char 256))
(if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256))
(uffi:convert-from-foreign-string name)
(error "gethostname() failed."))))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: gettime.cl,v 1.6 2002/03/14 21:03:12 kevin Exp $
+;;;; $Id: gettime.cl,v 1.7 2002/03/23 16:32:39 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(defun gettime ()
"Returns the local time"
- (let* ((time (uffi:allocate-foreign-object time-t)))
- (declare (type time-t time))
+ (uffi:with-foreign-object (time 'time-t)
+;; (declare (type time-t time))
(c-time time)
(let ((tm-ptr (the tm-pointer (c-localtime time))))
(declare (type tm-pointer tm-ptr))
(uffi:get-slot-value tm-ptr 'tm 'min)
(uffi:get-slot-value tm-ptr 'tm 'sec)
)))
- (uffi:free-foreign-object time)
- time-string))
- ))
+ time-string))))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: strtol.cl,v 1.11 2002/03/20 04:56:52 kevin Exp $
+;;;; $Id: strtol.cl,v 1.12 2002/03/23 16:32:39 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
their was no string at all, or an integer indicating position in string
of first non-valid character"
(let* ((str-native (uffi:convert-to-foreign-string str))
- (endptr (uffi:allocate-foreign-object char-ptr))
+ (endptr (uffi:allocate-foreign-object 'char-ptr))
(value (c-strtol str-native endptr base))
(endptr-value (uffi:deref-pointer endptr 'char-ptr)))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Mar 2002
;;;;
-;;;; $Id: union.cl,v 1.2 2002/03/21 08:30:10 kevin Exp $
+;;;; $Id: union.cl,v 1.3 2002/03/23 16:32:39 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(df :double))
(defun test-union-1 ()
- (let ((u (uffi:allocate-foreign-object tunion1)))
+ (let ((u (uffi:allocate-foreign-object 'tunion1)))
(setf (uffi:get-slot-value u 'tunion1 'uint)
(+ (char-code #\A)
(* 256 (char-code #\B))
(* 65536 (char-code #\C))
(* 16777216 255)))
- (format t "~&Should be #\A: ~S"
+ (format *standard-output* "~&Should be #\A: ~S"
(uffi:ensure-char-character
(uffi:get-slot-value u 'tunion1 'char)))
- (format t "~&Should be negative number: ~D"
+ (format *standard-output* "~&Should be negative number: ~D"
(uffi:get-slot-value u 'tunion1 'int))
- (format t "~&Should be positive number: ~D"
+ (format *standard-output* "~&Should be positive number: ~D"
(uffi:get-slot-value u 'tunion1 'uint))
(uffi:free-foreign-object u))
(values))