From: Kevin M. Rosenberg Date: Sat, 23 Mar 2002 16:32:39 +0000 (+0000) Subject: r1645: *** empty log message *** X-Git-Tag: v1.6.1~543 X-Git-Url: http://git.kpe.io/?p=uffi.git;a=commitdiff_plain;h=f73eb94e15649aba5fcfbe3a900aa72f31f46a96 r1645: *** empty log message *** --- diff --git a/ChangeLog b/ChangeLog index 0260b37..9f4b206 100644 --- a/ChangeLog +++ b/ChangeLog @@ -6,6 +6,15 @@ * 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 diff --git a/TODO b/TODO index 389df1d..05ebcb4 100644 --- a/TODO +++ b/TODO @@ -1,9 +1,2 @@ -- 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. diff --git a/VERSION b/VERSION index 2779245..69367fd 100644 --- a/VERSION +++ b/VERSION @@ -1 +1,2 @@ -0.2.13 +0.3.0 + diff --git a/doc/Makefile b/doc/Makefile index b252b02..c843fa5 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -5,7 +5,7 @@ # 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 # @@ -53,6 +53,7 @@ PDFFILE=${DOCFILE_BASE}.pdf 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 @@ -63,15 +64,15 @@ CHECK=nsgmls -s -C catalog || exit 1 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} diff --git a/doc/ref.sgml b/doc/ref.sgml index fcb08eb..732204a 100644 --- a/doc/ref.sgml +++ b/doc/ref.sgml @@ -877,7 +877,7 @@ can be freed. type - A unevaluated type of foreign object to allocate. + The type of foreign object to allocate. This parameter is evaluated. @@ -908,7 +908,7 @@ array of type that is size members Examples (def-struct ab (a :int) (b :double)) -(allocate-foreign-object ab) +(allocate-foreign-object 'ab) => #<ptr> @@ -973,6 +973,79 @@ array of type that is size members + + + with-foreign-object + Wraps the allocation of a foreign object around a body of code. + + Macro + + + Syntax + + with-foreign-object (var type) &body body => form-return + + + + Arguments and Values + + + var + + The variable name to bind. + + + + + type + + The type of foreign object to allocate. This parameter is evaluated. + + + + + form-return + + The result of evaluating the body. + + + + + + + Description + +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. + + + + Examples + +(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.")))) + + + + Side Effects + None. + + + Affected by + None. + + + Exceptional Situations + None. + + + pointer-address diff --git a/examples/arrays.cl b/examples/arrays.cl index e9bbbaa..61f31b2 100644 --- a/examples/arrays.cl +++ b/examples/arrays.cl @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -33,7 +33,7 @@ (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) diff --git a/examples/gethostname.cl b/examples/gethostname.cl index fcec16e..409afd9 100644 --- a/examples/gethostname.cl +++ b/examples/gethostname.cl @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -38,7 +38,7 @@ (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.")))) diff --git a/examples/gettime.cl b/examples/gettime.cl index 1201256..69b2f07 100644 --- a/examples/gettime.cl +++ b/examples/gettime.cl @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -44,8 +44,8 @@ (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)) @@ -57,9 +57,7 @@ (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)))) diff --git a/examples/strtol.cl b/examples/strtol.cl index eefee46..a115b2a 100644 --- a/examples/strtol.cl +++ b/examples/strtol.cl @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -36,7 +36,7 @@ Condition flag is T if all of string parses as a long, NIL if 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))) diff --git a/examples/union.cl b/examples/union.cl index b876699..d0d3281 100644 --- a/examples/union.cl +++ b/examples/union.cl @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -26,18 +26,18 @@ (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)) diff --git a/src/objects.cl b/src/objects.cl index b510b35..014fe9d 100644 --- a/src/objects.cl +++ b/src/objects.cl @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -21,22 +21,22 @@ (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) ) )) @@ -107,6 +107,7 @@ an array of TYPE with size SIZE." obj ) +;; TYPE is evaluated. (defmacro with-foreign-object ((var type) &rest body) #-(or cmu lispworks) ; default version `(let ((,var (allocate-foreign-object ,type))) @@ -115,12 +116,12 @@ an array of TYPE with size SIZE." (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) ) diff --git a/src/primitives.cl b/src/primitives.cl index 8a29b21..d41c75d 100644 --- a/src/primitives.cl +++ b/src/primitives.cl @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -23,7 +23,8 @@ "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 diff --git a/tests/arrays.cl b/tests/arrays.cl index e9bbbaa..61f31b2 100644 --- a/tests/arrays.cl +++ b/tests/arrays.cl @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -33,7 +33,7 @@ (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) diff --git a/tests/gethostname.cl b/tests/gethostname.cl index fcec16e..409afd9 100644 --- a/tests/gethostname.cl +++ b/tests/gethostname.cl @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -38,7 +38,7 @@ (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.")))) diff --git a/tests/gettime.cl b/tests/gettime.cl index 1201256..69b2f07 100644 --- a/tests/gettime.cl +++ b/tests/gettime.cl @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -44,8 +44,8 @@ (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)) @@ -57,9 +57,7 @@ (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)))) diff --git a/tests/strtol.cl b/tests/strtol.cl index eefee46..a115b2a 100644 --- a/tests/strtol.cl +++ b/tests/strtol.cl @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -36,7 +36,7 @@ Condition flag is T if all of string parses as a long, NIL if 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))) diff --git a/tests/union.cl b/tests/union.cl index b876699..d0d3281 100644 --- a/tests/union.cl +++ b/tests/union.cl @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -26,18 +26,18 @@ (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))