+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)
-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.
+cl-uffi (0.8.0-1) unstable; urgency=low
+
+ * Adds support for openmcl
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Thu, 19 Sep 2002 21:09:17 -0600
+
cl-uffi (0.7.1-1) unstable; urgency=low
* New upstream version
<para>Beta code is included with &uffi; for
</para>
<itemizedlist mark="opencircle">
- <listitem><para>&mcl; with MacOSX</para></listitem>
+ <listitem><para>&openmcl; and &mcl; with MacOSX</para></listitem>
</itemizedlist>
</sect1>
<!ENTITY ffi "<acronym>FFI</acronym>">
<!ENTITY cmucl "<application>CMUCL</application>">
<!ENTITY lw "<application>Lispworks</application>">
+<!ENTITY openmcl "<application>OpenMCL</application>">
<!ENTITY mcl "<application>MCL</application>">
<!ENTITY acl "<application>AllegroCL</application>">
<!ENTITY cl "<application>ANSI Common Lisp</application>">
# 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
#
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
;; 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
(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))))
;;;; 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
;;;;
(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"))
;;;; 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
;;;;
;;;; (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*)
(load (merge-pathnames
(make-pathname :name name
:type "cl"
- *load-truename*))))
-
+ *load-truename*)))))
(load-test "c-test-fns")
(load-test "arrays")
(load-test "union")
;;;; 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
;;;;
;;;; (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*)
(load (merge-pathnames
(make-pathname :name name
:type "cl"
- *load-truename*))))
-
+ *load-truename*)))))
(load-test "c-test-fns")
(load-test "arrays")
(load-test "union")
;;;; 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
;;;;
(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
;;;; 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
#+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))
`(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)
(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
;;;; 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
(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)))
,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)))))
;;;; 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
"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
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
;;;; 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
;;;
;;; 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))))))
`(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))
+
#:free-foreign-object
#:with-foreign-object
#:with-foreign-objects
+ #:size-of-foreign-type
#:pointer-address
#:deref-pointer
#:ensure-char-character
#:def-function
;; Libraries
+ #:find-foreign-library
#:load-foreign-library
-
- ;; Utilities
+ #:default-foreign-library-type
))
;;;; 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
(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))
`(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)
(: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))))
;;;; 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
+
+(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)))
+
+
+
# 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
#
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
;; 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
(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))))
;;;; 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
;;;;
(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"))
;;;; 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
;;;;
;;;; (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*)
(load (merge-pathnames
(make-pathname :name name
:type "cl"
- *load-truename*))))
-
+ *load-truename*)))))
(load-test "c-test-fns")
(load-test "arrays")
(load-test "union")
;;;; 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
;;;;
;;;; (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*)
(load (merge-pathnames
(make-pathname :name name
:type "cl"
- *load-truename*))))
-
+ *load-truename*)))))
(load-test "c-test-fns")
(load-test "arrays")
(load-test "union")
projects / uffi.git / commitdiff