From: Kevin M. Rosenberg Date: Fri, 20 Sep 2002 04:51:14 +0000 (+0000) Subject: r2784: *** empty log message *** X-Git-Tag: v1.6.1~308 X-Git-Url: http://git.kpe.io/?p=uffi.git;a=commitdiff_plain;h=e17a00289f90e820823ae17546eb5374e8f056e0 r2784: *** empty log message *** --- diff --git a/ChangeLog b/ChangeLog index 8ca4aa9..35e3f51 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,14 @@ +2002-09-19 Kevin Rosenberg (kevin@rosenberg.net) + - Integrate John Desoi's OpenMCL support into src-mcl + * examples/Makefile: add section for building on MacOS X (John Desoi) + * examples/test-examples: changed from mk: to asdf: package loading + * examples/run-examples: changed from mk: to asdf: package loading, + add conditional loading if UFFI not loaded (John Desoi) + * examples/compress.cl: Add dylib to library types for MacOSX (John Desoi) + * src-main/libraries.cl: add dylib as default library type on MacOSX (John Desoi) + 2002-09-16 Kevin Rosenberg (kevin@rosenberg.net) - - Restructure directories to move to a asdf definition file + - Restructure directories to move to a asdf definition file without pathnames. 2002-08-25 Kevin Rosenberg (kevin@rosenberg.net) diff --git a/NEWS b/NEWS index e4f8a8b..81b61ed 100644 --- a/NEWS +++ b/NEWS @@ -1,7 +1,3 @@ -UFFI now supports ASDF in addition to defsystem - -UFFI now supports MCL, though support is not yet complete. - -UFFI now tested and supported for FreeBSD with ACL and CMUCL and -with Solaris with ACL and CMUCL. +UFFI now uses ASDF system definition files. +UFFI now supports OpenMCL along with MCL. diff --git a/debian/changelog b/debian/changelog index 910e9c0..e1b79f6 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-uffi (0.8.0-1) unstable; urgency=low + + * Adds support for openmcl + + -- Kevin M. Rosenberg Thu, 19 Sep 2002 21:09:17 -0600 + cl-uffi (0.7.1-1) unstable; urgency=low * New upstream version diff --git a/doc/intro.sgml b/doc/intro.sgml index 082edf8..35e2ba5 100644 --- a/doc/intro.sgml +++ b/doc/intro.sgml @@ -49,7 +49,7 @@ FreeBSD 4.5, Solaris v2.8, and Microsoft Windows XP. Beta code is included with &uffi; for - &mcl; with MacOSX + &openmcl; and &mcl; with MacOSX diff --git a/doc/uffi.sgml b/doc/uffi.sgml index fa75383..48192e8 100644 --- a/doc/uffi.sgml +++ b/doc/uffi.sgml @@ -5,6 +5,7 @@ FFI"> CMUCL"> Lispworks"> +OpenMCL"> MCL"> AllegroCL"> ANSI Common Lisp"> diff --git a/examples/Makefile b/examples/Makefile index 2c3ee7e..ebfe4d5 100644 --- a/examples/Makefile +++ b/examples/Makefile @@ -5,7 +5,7 @@ # Programer: Kevin M. Rosenberg # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.14 2002/04/28 02:28:45 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.15 2002/09/20 04:51:14 kevin Exp $ # # This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg # @@ -27,8 +27,9 @@ SHARED_CC_OPT=-fPIC -DPIC SHARED_LD_OPT=-shared # For Linux (ALL) and FreeBSD (ACL) # For MacOSX (ACL) -#SHARED_CC_OPT=-dynamic -#SHARED_LD_OPT=-bundle /usr/lib/bundle1.o -undefined suppress # -o foo.dylib foo.o +# cc -dynamic -c c-test-fns.c -o foo.o +# ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress -o +# c-test-fns.dylib foo.o # Use these for Sun's C compiler and Solaris (ACL) #CC=cc diff --git a/examples/acl-compat-tester.cl b/examples/acl-compat-tester.cl index 9124c4a..cfb095e 100644 --- a/examples/acl-compat-tester.cl +++ b/examples/acl-compat-tester.cl @@ -24,7 +24,7 @@ ;; Place, Suite 330, Boston, MA 02111-1307 USA ;; ;;;; from the original ACL 6.1 sources: -;; $Id: acl-compat-tester.cl,v 1.1 2002/07/26 03:24:29 kevin Exp $ +;; $Id: acl-compat-tester.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ (defpackage :util.test @@ -398,17 +398,17 @@ discriminate on new versus known failures." (if catch-breaks `(handler-case (values-list (cons t (multiple-value-list ,form))) (error (condition) - (declare (ignore-if-unused condition)) + (declare (ignorable condition)) ,@(if announce `((format *error-output* "~&Error: ~a~%" condition))) nil) (simple-break (condition) - (declare (ignore-if-unused condition)) + (declare (ignorable condition)) ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition)) ) nil)) `(handler-case (values-list (cons t (multiple-value-list ,form))) (error (condition) - (declare (ignore-if-unused condition)) + (declare (ignorable condition)) ,@(if announce `((format *error-output* "~&Error: ~a~%" condition))) nil)))) diff --git a/examples/compress.cl b/examples/compress.cl index fb71d1b..475be12 100644 --- a/examples/compress.cl +++ b/examples/compress.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: compress.cl,v 1.11 2002/04/02 21:29:45 kevin Exp $ +;;;; $Id: compress.cl,v 1.12 2002/09/20 04:51:14 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -22,7 +22,7 @@ (uffi:find-foreign-library "libz" '("/usr/local/lib/" "/usr/lib/" "/zlib/") - :types '("so" "a")) + :types '("so" "a" "dylib")) :module "zlib" :supporting-libraries '("c")) (warn "Unable to load zlib")) diff --git a/examples/run-examples.cl b/examples/run-examples.cl index 5701e44..e433205 100644 --- a/examples/run-examples.cl +++ b/examples/run-examples.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: run-examples.cl,v 1.1 2002/07/26 03:24:29 kevin Exp $ +;;;; $Id: run-examples.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,7 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(mk:load-system :uffi) +#-uffi (asdf:oos 'asdf:load-op :uffi) (pushnew :examples-uffi cl:*features*) @@ -24,8 +24,7 @@ (load (merge-pathnames (make-pathname :name name :type "cl" - *load-truename*)))) - + *load-truename*))))) (load-test "c-test-fns") (load-test "arrays") (load-test "union") diff --git a/examples/test-examples.cl b/examples/test-examples.cl index b23b3ce..2a0f715 100644 --- a/examples/test-examples.cl +++ b/examples/test-examples.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: test-examples.cl,v 1.1 2002/07/26 03:24:29 kevin Exp $ +;;;; $Id: test-examples.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,13 +16,11 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -#-uffi -(mk:load-system :uffi) - -#-allegro -(load (make-pathname :name "acl-compat-tester" :type "cl" - :defaults *load-truename*)) +#-uffi (asdf:oos 'asdf:load-op :uffi) +(unless (ignore-errors (find-package :util.test)) + (load (make-pathname :name "acl-compat-tester" :type "cl" + :defaults *load-truename*))) (defun do-tests () (pushnew :test-uffi cl:*features*) @@ -32,8 +30,7 @@ (load (merge-pathnames (make-pathname :name name :type "cl" - *load-truename*)))) - + *load-truename*))))) (load-test "c-test-fns") (load-test "arrays") (load-test "union") diff --git a/src-main/libraries.cl b/src-main/libraries.cl index b37549b..c16cda2 100644 --- a/src-main/libraries.cl +++ b/src-main/libraries.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: libraries.cl,v 1.1 2002/09/16 17:54:30 kevin Exp $ +;;;; $Id: libraries.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -25,7 +25,8 @@ (defun default-foreign-library-type () "Returns string naming default library type for platform" #+(or win32 mswindows) "dll" - #-(or win32 mswindows) "so") + #-(or win32 mswindows macosx) "so" + #+macosx "dylib") (defun find-foreign-library (names directories &key types drive-letters) "Looks for a foreign library. directories can be a single diff --git a/src-mcl/aggregates.cl b/src-mcl/aggregates.cl index eb4be75..b59615a 100644 --- a/src-mcl/aggregates.cl +++ b/src-mcl/aggregates.cl @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg and John DeSoi ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: aggregates.cl,v 1.1 2002/09/16 17:57:43 kevin Exp $ +;;;; $Id: aggregates.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and John DeSoi @@ -48,7 +48,8 @@ of the enum-name name, separator-string, and field-name" #+allegro `((ff:def-foreign-type ,enum-name :int)) #+lispworks `((fli:define-c-typedef ,enum-name :int)) #+cmu `((alien:def-alien-type ,enum-name alien:signed)) - #+mcl `((def-mcl-type ,enum-name :integer)) + #-openmcl `((def-mcl-type ,enum-name :integer)) + #+openmcl `((ccl::def-foreign-type ,enum-name :int)) (nreverse constants))) cmds)) @@ -58,13 +59,37 @@ of the enum-name name, separator-string, and field-name" `(def-mcl-type ,name-array '(:array ,type))) -; this is how rref expands array slot access (minus adding the struct offset) + +; so we could allow '(:array :long) or deref with other type like :long only +(defun array-type (type) + (let ((result type)) + (when (listp type) + (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type))) + (when (and (listp type-list) (eq (car type-list) :array)) + (setf result (cadr type-list))))) + result)) + + (defmacro deref-array (obj type i) "Returns a field from a row" - `(,(accessor-symbol type :get) ,obj (* (the fixnum ,i) ,(foreign-object-size type)))) + (let* ((array-type (array-type type)) + (local-type (convert-from-uffi-type array-type :allocation)) + (accessor (first (macroexpand `(ccl:pref obj ,local-type))))) + `(,accessor + ,obj + (* (the fixnum ,i) ,(size-of-foreign-type local-type))))) + +; this expands to the %set-xx functions which has different params than %put-xx (defmacro deref-array-set (obj type i value) - `(,(accessor-symbol type :set) ,obj ,value (* (the fixnum ,i) ,(foreign-object-size type)))) + (let* ((array-type (array-type type)) + (local-type (convert-from-uffi-type array-type :allocation)) + (accessor (first (macroexpand `(ccl:pref obj ,local-type)))) + (settor (first (macroexpand `(setf (,accessor obj ,local-type) value))))) + `(,settor + ,obj + (* (the fixnum ,i) ,(size-of-foreign-type local-type)) + ,value))) (defsetf deref-array deref-array-set) @@ -84,23 +109,45 @@ of the enum-name name, separator-string, and field-name" (push def processed)))) (nreverse processed))) - +#-openmcl (defmacro def-struct (name &rest fields) `(ccl:defrecord ,name ,@(process-struct-fields name fields nil))) - +#-openmcl (defmacro def-union (name &rest fields) `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))) +#+openmcl +(defmacro def-struct (name &rest fields) + `(ccl::def-foreign-type nil + (:struct ,name ,@(process-struct-fields name fields nil)))) + +#+openmcl +(defmacro def-union (name &rest fields) + `(ccl::def-foreign-type nil + (:union ,name ,@(process-struct-fields name fields nil)))) + ; Assuming everything is pointer based - no support for Mac handles (defmacro get-slot-value (obj type slot) ;use setf to set values - `(ccl:pref ,obj ,(read-from-string (format nil "~a.~a" type slot)))) + `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))) + +(defmacro set-slot-value (obj type slot value) ;use setf to set values + `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value)) + +(defsetf get-slot-value set-slot-value) + +#-openmcl (defmacro get-slot-pointer (obj type slot) `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))) +#+openmcl +(defmacro get-slot-pointer (obj type slot) + `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot))) + (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field)))))) + #| a few simple tests diff --git a/src-mcl/functions.cl b/src-mcl/functions.cl index 2db1fd9..693f15d 100644 --- a/src-mcl/functions.cl +++ b/src-mcl/functions.cl @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg and John DeSoi ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: functions.cl,v 1.1 2002/09/16 17:57:43 kevin Exp $ +;;;; $Id: functions.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and John DeSoi @@ -20,37 +20,37 @@ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :uffi) + +(defun make-lisp-name (name) + (let ((converted (substitute #\- #\_ name))) + (intern + #+case-sensitive converted + #-case-sensitive (string-upcase converted)))) + +#-openmcl (defun process-function-args (args) (if (null args) - #+lispworks nil - #+allegro '(:void) - #+cmu nil - #+mcl nil - (let (processed) - (dolist (arg args) - (push (process-one-function-arg arg) processed)) - (nreverse processed)))) + nil + (let (processed) + (dolist (arg args) + (push (process-one-function-arg arg) processed)) + (nreverse processed)))) +#-openmcl (defun process-one-function-arg (arg) (let ((name (car arg)) (type (convert-from-uffi-type (cadr arg) :routine))) (if (and (listp type) (listp (car type))) - (append (list name) type) + (append (list name) type) (list name type)) )) -(defun allegro-convert-return-type (type) - (if (and (listp type) (not (listp (car type)))) - (list type) - type)) ;; name is either a string representing foreign name, or a list ;; of foreign-name as a string and lisp name as a symbol - - +#-openmcl (defmacro def-function (names args &key module returning) (declare (ignore module)) - (let* ((result-type (convert-from-uffi-type returning :return)) (function-args (process-function-args args)) (foreign-name (if (atom names) names (car names))) @@ -61,10 +61,33 @@ ,result-type)))) -(defun make-lisp-name (name) - (let ((converted (substitute #\- #\_ name))) - (intern - #+case-sensitive converted - #-case-sensitive (string-upcase converted)))) +#+openmcl +(defun process-function-args (args) + (if (null args) + (values nil nil) + (let ((processed nil) + (params nil) + name type) + (dolist (arg args) + (setf name (car arg)) + (setf type (convert-from-uffi-type (cadr arg) :routine)) + ;(when (and (listp type) (eq (car type) :address)) + ;(setf type :address)) + (push name params) + (push type processed) + (push name processed)) + (values (nreverse params) (nreverse processed))))) + +#+openmcl +(defmacro def-function (names args &key module returning) + (declare (ignore module)) + (let* ((result-type (convert-from-uffi-type returning :return)) + (foreign-name (if (atom names) names (car names))) + (lisp-name (if (atom names) (make-lisp-name names) (cadr names)))) + #+darwinppc-target + (setf foreign-name (concatenate 'string "_" foreign-name)) + (multiple-value-bind (params args) (process-function-args args) + `(defun ,lisp-name ,params + (ccl::external-call ,foreign-name ,@args ,result-type))))) diff --git a/src-mcl/libraries.cl b/src-mcl/libraries.cl index d7075c1..ad6497d 100644 --- a/src-mcl/libraries.cl +++ b/src-mcl/libraries.cl @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg and John DeSoi ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: libraries.cl,v 1.1 2002/09/16 17:57:43 kevin Exp $ +;;;; $Id: libraries.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and John DeSoi @@ -24,13 +24,28 @@ "List of foreign libraries loaded. Used to prevent reloading a library") ;in MCL calling this more than once for the same library does not do anything -(defmacro load-foreign-library (filename &key module supporting-libraries) - (declare (ignore module supporting-libraries)) +#-openmcl +(defmacro load-foreign-library (filename &key module supporting-libraries force-load) + (declare (ignore module supporting-libraries force-load)) `(eval-when (:compile-toplevel :load-toplevel :execute) (when (ccl:add-to-shared-library-search-path ,filename t) (pushnew ,filename *loaded-libraries*)))) -;; Copied directly from main source without MCL specializations + +; Note we are not dealing with OpenMCL's ability to close the library +; As of v0.13 .dylibs can't be closed but bundles can. See the docs for the latest. +#+openmcl +(defmacro load-foreign-library (filename &key module supporting-libraries force-load) + (declare (ignore module supporting-libraries force-load)) + `(let ((path (if (pathnamep ,filename) (namestring ,filename) ,filename))) + (when (stringp path) + (if (position path *loaded-libraries* :test #'string-equal) + t + (when (ccl:open-shared-library path) + (pushnew path *loaded-libraries*) + t))))) + + (defun find-foreign-library (names directories &key types drive-letters) "Looks for a foreign library. directories can be a single string or a list of strings of candidate directories. Use default @@ -73,8 +88,15 @@ library type if type is not specified." nil) -;; Copied directly from main source without MCL specializations + (defun default-foreign-library-type () "Returns string naming default library type for platform" #+(or win32 mswindows) "dll" - #-(or win32 mswindows) "so") \ No newline at end of file + #-(or win32 mswindows mcl) "so" + #+openmcl '("dylib" "so" nil) + #-openmcl '(nil)) + + + + + \ No newline at end of file diff --git a/src-mcl/objects.cl b/src-mcl/objects.cl index c339b4d..82adf16 100644 --- a/src-mcl/objects.cl +++ b/src-mcl/objects.cl @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg and John DeSoi ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: objects.cl,v 1.1 2002/09/16 17:57:43 kevin Exp $ +;;;; $Id: objects.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and John DeSoi @@ -24,34 +24,49 @@ ;;; ;;; Some MCL specific utilities ;;; -(defun foreign-object-size (type) - "Returns the size for the specified mcl type or record type" - (let ((mcl-type (ccl:find-mactype type nil t))) - (if mcl-type - (ccl::mactype-record-size mcl-type) - (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)) ) ) ) ;error if not a record - -; trap macros don't work right directly in the macros +; trap macros don't work right directly in the macros (eval-when (:compile-toplevel :load-toplevel :execute) +#-openmcl (defun new-ptr (size) (#_NewPtr size)) +#-openmcl (defun dispose-ptr (ptr) (#_DisposePtr ptr)) +#+openmcl +(defmacro new-ptr (size) + `(ccl::malloc ,size)) + +#+openmcl +(defmacro dispose-ptr (ptr) + `(ccl::free ,ptr)) + ) ;;; ;;; Start of standard UFFI ;;; +(defun size-of-foreign-type (type) + "Returns the size for the specified mcl type or record type" + #+openmcl + (ccl::%foreign-type-or-record-size type :bytes) + #-openmcl + (let ((mcl-type (ccl:find-mactype type nil t))) + (if mcl-type + (ccl::mactype-record-size mcl-type) + (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)) ) ) ) ;error if not a record + + + (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." (if (eq size :unspecified) - `(new-ptr ,(foreign-object-size (convert-from-uffi-type type :allocation))) - `(new-ptr ,(* size (foreign-object-size (convert-from-uffi-type type :allocation)))))) + `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation))) + `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))))) @@ -67,47 +82,49 @@ an array of TYPE with size SIZE." `(ccl:%null-ptr)) -;! need to check uffi update and see if :routine is the right context +;already a macptr +(defmacro char-array-to-pointer (obj) + obj) -(defun accessor-symbol (type get-or-set) - "Returns the symbol used to access the foreign type." - (let* ((mcl-type (convert-from-uffi-type (eval type) :routine)) - (mac-type (ccl:find-mactype mcl-type)) - name) - (ecase get-or-set - (:get (setf name (ccl::mactype-get-function mac-type))) - (:set (setf name (ccl::mactype-set-function mac-type)))) - (find-symbol (symbol-name name) :ccl))) (defmacro deref-pointer (ptr type) - `(,(accessor-symbol type :get) ,ptr)) - + `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref))) (defmacro deref-pointer-set (ptr type value) - `(,(accessor-symbol type :set) ,ptr ,value)) - + `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value)) (defsetf deref-pointer deref-pointer-set) +(defmacro ensure-char-character (obj) + #-openmcl obj + #+openmcl `(code-char ,obj)) + + +(defmacro ensure-char-integer (obj) + #-openmcl `(char-code ,obj) + #+openmcl obj) + + (defmacro pointer-address (obj) `(ccl:%ptr-to-int ,obj)) + (defmacro with-foreign-objects (bindings &rest body) - (let ((simple nil) (recs nil) type) + (let ((params nil) type count) (dolist (spec (reverse bindings)) ;keep order - macroexpands to let* (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate)) - (if (ccl:mactype-p type) - (push (list (first spec) (foreign-object-size type)) simple) - (push spec recs))) - (cond ((and simple recs) - `(ccl:%stack-block ,simple - (ccl:rlet ,recs - ,@body))) - (simple `(ccl:%stack-block ,simple ,@body)) - (recs `(ccl:rlet ,recs ,@body))))) + (setf count 1) + (when (and (listp type) (eq (first type) :array)) + (setf count (nth 2 type)) + (unless (integerp count) (error "Invalid size for array: ~a" type)) + (setf type (nth 1 type))) + (push (list (first spec) (* count (size-of-foreign-type type))) params)) + `(ccl:%stack-block ,params ,@body))) (defmacro with-foreign-object ((var type) &rest body) - `(with-foreign-objects ((,var ,type)) ,@body)) + `(with-foreign-objects ((,var ,type)) + ,@body)) + diff --git a/src-mcl/package.cl b/src-mcl/package.cl index b77e99a..02849bc 100644 --- a/src-mcl/package.cl +++ b/src-mcl/package.cl @@ -41,6 +41,7 @@ #:free-foreign-object #:with-foreign-object #:with-foreign-objects + #:size-of-foreign-type #:pointer-address #:deref-pointer #:ensure-char-character @@ -65,7 +66,7 @@ #:def-function ;; Libraries + #:find-foreign-library #:load-foreign-library - - ;; Utilities + #:default-foreign-library-type )) diff --git a/src-mcl/primitives.cl b/src-mcl/primitives.cl index 6e49d87..0f85ab1 100644 --- a/src-mcl/primitives.cl +++ b/src-mcl/primitives.cl @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg and John DeSoi ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: primitives.cl,v 1.1 2002/09/16 17:57:43 kevin Exp $ +;;;; $Id: primitives.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and John DeSoi @@ -20,9 +20,30 @@ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :uffi) + +(defvar *keyword-package* (find-package "KEYWORD")) + +; MCL and OpenMCL expect a lot of FFI elements to be keywords (e.g. struct field names in OpenMCL) +; So this provides a function to convert any quoted symbols to keywords. +(defun keyword (obj) + (cond ((keywordp obj) + obj) + ((null obj) + nil) + ((symbolp obj) + (intern (symbol-name obj) *keyword-package*)) + ((and (listp obj) (eq (car obj) 'cl:quote)) + (keyword (cadr obj))) + ((stringp obj) + (intern obj *keyword-package*)) + (t + obj))) + + ; Wrapper for unexported function we have to use +#-openmcl (defmacro def-mcl-type (name type) - `(ccl::def-mactype (quote ,name) (ccl:find-mactype ,type))) + `(ccl::def-mactype ,(keyword name) (ccl:find-mactype ,type))) (defmacro def-constant (name value &key (export nil)) @@ -42,14 +63,20 @@ supports takes advantage of this optimization." `(zerop ,val)) -(defmacro def-foreign-type (name type) - `(def-mcl-type ,name (convert-from-uffi-type ,type :type))) +(defmacro def-foreign-type (name uffi-type) + (let ((type (convert-from-uffi-type uffi-type :type))) + (unless (keywordp type) + (setf type `(quote ,type))) + #-openmcl + `(def-mcl-type ,(keyword name) ,type) + #+openmcl + `(ccl::def-foreign-type ,(keyword name) ,type))) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar +type-conversion-hash+ (make-hash-table :size 20))) - +#-openmcl (defconstant +type-conversion-list+ '((* . :pointer) (:void . :void) (:short . :short) @@ -57,35 +84,60 @@ supports takes advantage of this optimization." (:cstring . :string) (:char . :character) (:unsigned-char . :unsigned-byte) - (:byte . :byte) + (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte) (:int . :integer) (:unsigned-int . :unsigned-integer) (:long . :long) (:unsigned-long . :unsigned-long) (:float . :single-float) (:double . :double-float) (:array . :array))) +#+openmcl +(defconstant +type-conversion-list+ + '((* . :address) (:void . :void) + (:short . :short) + (:pointer-void . :address) + (:cstring . :address) + (:char . :signed-char) + (:unsigned-char . :unsigned-char) + (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte) + (:int . :int) (:unsigned-int . :unsigned-int) + (:long . :long) (:unsigned-long . :unsigned-long) + (:long-long . :signed-doubleword) (:unsigned-long-long . :unsigned-doubleword) + (:float . :single-float) (:double . :double-float) + (:array . :array))) + (dolist (type +type-conversion-list+) (setf (gethash (car type) +type-conversion-hash+) (cdr type))) (defmethod ph (&optional (os *standard-output*)) (maphash #'(lambda (k v) (format os "~&~S => ~S" k v)) +type-conversion-hash+)) - -(defun convert-from-uffi-type (type context) - "Converts from a uffi type to an implementation specific type" - (if (atom type) - (cond - #+mcl - ((and (eq type :void) (eq context :return)) nil) - (t - (let ((found-type (gethash type +type-conversion-hash+))) - (if found-type - found-type - type)))) - (cons (convert-from-uffi-type (first type) context) - (convert-from-uffi-type (rest type) context)))) - - + +(defun basic-convert-from-uffi-type (type) + (let ((found-type (gethash type +type-conversion-hash+))) + (if found-type + found-type + (keyword type)))) +(defun %convert-from-uffi-type (type context) + "Converts from a uffi type to an implementation specific type" + (if (atom type) + (cond + #-openmcl + ((and (eq type :void) (eq context :return)) nil) + (t (basic-convert-from-uffi-type type))) + (if (eq (car type) 'cl:quote) + (%convert-from-uffi-type (cadr type) context) + (cons (%convert-from-uffi-type (first type) context) + (%convert-from-uffi-type (rest type) context))))) +(defun convert-from-uffi-type (type context) + (let ((result (%convert-from-uffi-type type context))) + (cond + ((atom result) result) + #+openmcl + ((eq (car result) :address) :address) + #-openmcl + ((and (eq (car result) :pointer) (eq context :allocation) :pointer)) + (t result)))) diff --git a/src-mcl/strings.cl b/src-mcl/strings.cl index ccf6b5d..12ff2ac 100644 --- a/src-mcl/strings.cl +++ b/src-mcl/strings.cl @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg and John DeSoi ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: strings.cl,v 1.1 2002/09/16 17:57:43 kevin Exp $ +;;;; $Id: strings.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and John DeSoi @@ -194,5 +194,16 @@ that CMU automatically converts strings from c-calls." + +(defmacro with-foreign-string ((foreign-string lisp-string) &body body) + (let ((result (gensym))) + `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string)) + (,result (progn ,@body))) + (declare (dynamic-extent ,foreign-string)) + (free-foreign-object ,foreign-string) + ,result))) + + + diff --git a/tests/Makefile b/tests/Makefile index 2c3ee7e..ebfe4d5 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -5,7 +5,7 @@ # Programer: Kevin M. Rosenberg # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.14 2002/04/28 02:28:45 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.15 2002/09/20 04:51:14 kevin Exp $ # # This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg # @@ -27,8 +27,9 @@ SHARED_CC_OPT=-fPIC -DPIC SHARED_LD_OPT=-shared # For Linux (ALL) and FreeBSD (ACL) # For MacOSX (ACL) -#SHARED_CC_OPT=-dynamic -#SHARED_LD_OPT=-bundle /usr/lib/bundle1.o -undefined suppress # -o foo.dylib foo.o +# cc -dynamic -c c-test-fns.c -o foo.o +# ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress -o +# c-test-fns.dylib foo.o # Use these for Sun's C compiler and Solaris (ACL) #CC=cc diff --git a/tests/acl-compat-tester.cl b/tests/acl-compat-tester.cl index 9124c4a..cfb095e 100644 --- a/tests/acl-compat-tester.cl +++ b/tests/acl-compat-tester.cl @@ -24,7 +24,7 @@ ;; Place, Suite 330, Boston, MA 02111-1307 USA ;; ;;;; from the original ACL 6.1 sources: -;; $Id: acl-compat-tester.cl,v 1.1 2002/07/26 03:24:29 kevin Exp $ +;; $Id: acl-compat-tester.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ (defpackage :util.test @@ -398,17 +398,17 @@ discriminate on new versus known failures." (if catch-breaks `(handler-case (values-list (cons t (multiple-value-list ,form))) (error (condition) - (declare (ignore-if-unused condition)) + (declare (ignorable condition)) ,@(if announce `((format *error-output* "~&Error: ~a~%" condition))) nil) (simple-break (condition) - (declare (ignore-if-unused condition)) + (declare (ignorable condition)) ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition)) ) nil)) `(handler-case (values-list (cons t (multiple-value-list ,form))) (error (condition) - (declare (ignore-if-unused condition)) + (declare (ignorable condition)) ,@(if announce `((format *error-output* "~&Error: ~a~%" condition))) nil)))) diff --git a/tests/compress.cl b/tests/compress.cl index fb71d1b..475be12 100644 --- a/tests/compress.cl +++ b/tests/compress.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: compress.cl,v 1.11 2002/04/02 21:29:45 kevin Exp $ +;;;; $Id: compress.cl,v 1.12 2002/09/20 04:51:14 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -22,7 +22,7 @@ (uffi:find-foreign-library "libz" '("/usr/local/lib/" "/usr/lib/" "/zlib/") - :types '("so" "a")) + :types '("so" "a" "dylib")) :module "zlib" :supporting-libraries '("c")) (warn "Unable to load zlib")) diff --git a/tests/run-examples.cl b/tests/run-examples.cl index 5701e44..e433205 100644 --- a/tests/run-examples.cl +++ b/tests/run-examples.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: run-examples.cl,v 1.1 2002/07/26 03:24:29 kevin Exp $ +;;;; $Id: run-examples.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,7 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(mk:load-system :uffi) +#-uffi (asdf:oos 'asdf:load-op :uffi) (pushnew :examples-uffi cl:*features*) @@ -24,8 +24,7 @@ (load (merge-pathnames (make-pathname :name name :type "cl" - *load-truename*)))) - + *load-truename*))))) (load-test "c-test-fns") (load-test "arrays") (load-test "union") diff --git a/tests/test-examples.cl b/tests/test-examples.cl index b23b3ce..2a0f715 100644 --- a/tests/test-examples.cl +++ b/tests/test-examples.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: test-examples.cl,v 1.1 2002/07/26 03:24:29 kevin Exp $ +;;;; $Id: test-examples.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,13 +16,11 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -#-uffi -(mk:load-system :uffi) - -#-allegro -(load (make-pathname :name "acl-compat-tester" :type "cl" - :defaults *load-truename*)) +#-uffi (asdf:oos 'asdf:load-op :uffi) +(unless (ignore-errors (find-package :util.test)) + (load (make-pathname :name "acl-compat-tester" :type "cl" + :defaults *load-truename*))) (defun do-tests () (pushnew :test-uffi cl:*features*) @@ -32,8 +30,7 @@ (load (merge-pathnames (make-pathname :name name :type "cl" - *load-truename*)))) - + *load-truename*))))) (load-test "c-test-fns") (load-test "arrays") (load-test "union")