+cl-uffi (0.9.0-1) unstable; urgency=low
+
+ * Reorganize directories, merge MCL/OpenMCL into main code
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Mon, 30 Sep 2002 01:32:03 -0600
+
cl-uffi (0.8.6-1) unstable; urgency=low
* Fix :pointer-self for OpenMCL.
* Multiple changes to support OpenMCL with CLSQL
- -- Kevin M. Rosenberg <kmr@debian.org> Sun, 29 Sep 2002 14:14:01 -0600
+ -- Kevin M. Rosenberg <kmr@debian.org> Mon, 30 Sep 2002 01:31:37 -0600
cl-uffi (0.8.5-1) unstable; urgency=low
dh_testroot
dh_clean -k
dh_installdirs --all $(clc-systems) $(clc-source)
- dh_installdirs -p $(debpkg) $(doc-dir) $(clc-uffi)/src-main $(clc-uffi)/src-mcl
+ dh_installdirs -p $(debpkg) $(doc-dir) $(clc-uffi)/src
# Add here commands to install the package into debian/uffi.
dh_install uffi.asd $(clc-uffi)
- dh_install "src-main/*.cl" $(clc-uffi)/src-main
- dh_install "src-mcl/*.cl" $(clc-uffi)/src-mcl
+ dh_install "src/*.cl" $(clc-uffi)/src
dh_link $(clc-uffi)/uffi.asd $(clc-systems)/uffi.asd
rm -rf doc/html
+++ /dev/null
-some notes:
- we need the :pascal (:stdcall) calling conventions for
- (def-function names args &key module returning calling-convention)
- so I added this. calling-convention defaults to :cdecl
- but on win32 we mostly use :stdcall
-
- #+corman is invalid, #+cormanlisp instead
-
- cormanlisp doesn't need to load and register the dll, since the underlying
- LoadLibrary() call does this. we need the module keyword for def-function
-instead.
- (should probably default to kernel32.dll)
- I'll think about library.cl, but we'll need more real-world win32 examples.
- (ideally the complete winapi :)
- I also have to look at valentina.
-
-patch -p0 < corman.diff
---
-Reini Urban
-http://xarch.tu-graz.ac.at/home/rurban/
---------------269CD5B1F75AF20CFDFE4FEE
-Content-Type: text/plain; charset=us-ascii; name="corman.diff"
-Content-Disposition: inline; filename="corman.diff"
-Content-Transfer-Encoding: 7bit
-
---- ./examples/getenv-ccl.cl~ Tue Apr 9 21:08:18 2002
-+++ ./examples/getenv-ccl.cl Tue Apr 9 20:58:16 2002
-@@ -0,0 +1,87 @@
-+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-+;;;; *************************************************************************
-+;;;; FILE IDENTIFICATION
-+;;;;
-+;;;; Name: getenv-ccl.cl
-+;;;; Purpose: cormanlisp version
-+;;;; Programmer: "Joe Marshall" <prunesquallor@attbi.com>
-+;;;; Date Started: Feb 2002
-+;;;;
-+;;;; $Id: corman-uffi.cl,v 1.1 2002/09/16 17:57:43 kevin Exp $
-+;;;;
-+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-+;;;;
-+;;;; UFFI users are granted the rights to distribute and use this software
-+;;;; as governed by the terms of the Lisp Lesser GNU Public License
-+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-+;;;; *************************************************************************
-+
-+(in-package :cl-user)
-+
-+(ct:defun-dll c-getenv ((lpname LPSTR)
-+ (lpbuffer LPSTR)
-+ (nsize LPDWORD))
-+ :library-name "kernel32.dll"
-+ :return-type DWORD
-+ :entry-name "GetEnvironmentVariableA"
-+ :linkage-type :pascal)
-+
-+(defun getenv (name)
-+ (let ((nsizebuf (ct:malloc (sizeof :long)))
-+ (buffer (ct:malloc 1))
-+ (cname (ct:lisp-string-to-c-string name)))
-+ (setf (ct:cref lpdword nsizebuf 0) 0)
-+ (let* ((needed-size (c-getenv cname buffer nsizebuf))
-+ (buffer1 (ct:malloc (1+ needed-size))))
-+ (setf (ct:cref lpdword nsizebuf 0) needed-size)
-+ (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf))
-+ nil
-+ (ct:c-string-to-lisp-string buffer1))
-+ (ct:free buffer1)
-+ (ct:free nsizebuf)))))
-+
-+(defun cl:user-homedir-pathname (&optional host)
-+ (cond ((or (stringp host)
-+ (and (consp host)
-+ (every #'stringp host))) nil)
-+ ((or (eq host :unspecific)
-+ (null host))
-+ (let ((homedrive (getenv "HOMEDRIVE"))
-+ (homepath (getenv "HOMEPATH")))
-+ (parse-namestring
-+ (if (and (stringp homedrive)
-+ (stringp homepath)
-+ (= (length homedrive) 2)
-+ (> (length homepath) 0))
-+ (concatenate 'string homedrive homepath "\\")
-+ "C:\\"))))
-+ (t (error "HOST must be a string, list of strings, NIL or :unspecific"))))
-+
-+;|
-+(uffi:def-function ("getenv" c-getenv)
-+ ((name :cstring))
-+ :returning :cstring)
-+
-+(defun my-getenv (key)
-+ "Returns an environment variable, or NIL if it does not exist"
-+ (check-type key string)
-+ (uffi:with-cstring (key-native key)
-+ (uffi:convert-from-cstring (c-getenv key-native))))
-+
-+#+examples-uffi
-+(progn
-+ (flet ((print-results (str)
-+ (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
-+ (print-results "USER")
-+ (print-results "_FOO_")))
-+
-+
-+#+test-uffi
-+(progn
-+ (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
-+ (util.test:test (and (stringp (my-getenv "USER"))
-+ (< 0 (length (my-getenv "USER"))))
-+ t :fail-info "Error retrieving getenv")
-+)
-+
-+|;
-\ No newline at end of file
---- ./Makefile~ Tue Apr 9 20:03:18 2002
-+++ ./Makefile Tue Apr 9 20:38:03 2002
-@@ -64,3 +64,7 @@
-
- wwwdist: dist
- @./copy
-+
-+TAGS:
-+ if [ -f TAGS ]; then mv -f TAGS TAGS~; fi
-+ find . -name \*.cl -exec /usr/bin/etags -a \{\} \;
---- ./set-logical.cl~ Tue Apr 9 20:03:20 2002
-+++ ./set-logical.cl Tue Apr 9 20:35:44 2002
-@@ -35,10 +35,10 @@
- #+clisp "clisp"
- #+cmu "cmucl"
- #+sbcl "sbcl"
-- #+corman "corman"
-+ #+cormanlisp "cormanlisp"
- #+mcl "mcl"
- #+openmcl "openmcl"
-- #-(or allegro lispworks clisp cmu sbcl corman mcl openmcl) "unknown")
-+ #-(or allegro lispworks clisp cmu sbcl cormanlisp mcl openmcl) "unknown")
-
- (defun set-logical-host-for-pathname (host base-pathname)
- (setf (logical-pathname-translations host)
---- ./src/functions.cl~ Tue Apr 9 20:03:24 2002
-+++ ./src/functions.cl Tue Apr 9 21:00:07 2002
-@@ -3,7 +3,7 @@
- ;;;; FILE IDENTIFICATION
- ;;;;
- ;;;; Name: function.cl
--;;;; Purpose: UFFI source to C function defintions
-+;;;; Purpose: UFFI source to C function definitions
- ;;;; Programmer: Kevin M. Rosenberg
- ;;;; Date Started: Feb 2002
- ;;;;
-@@ -21,9 +21,8 @@
-
- (defun process-function-args (args)
- (if (null args)
-- #+lispworks nil
-+ #+(or lispworks cmu cormanlisp) nil
- #+allegro '(:void)
-- #+cmu nil
- (let (processed)
- (dolist (arg args)
- (push (process-one-function-arg arg) processed))
-@@ -34,7 +33,7 @@
- (type (convert-from-uffi-type (cadr arg) :routine)))
- #+cmu
- (list name type :in)
-- #+(or allegro lispworks)
-+ #+(or allegro lispworks cormanlisp)
- (if (and (listp type) (listp (car type)))
- (append (list name) type)
- (list name type))
-@@ -47,15 +46,15 @@
-
- ;; name is either a string representing foreign name, or a list
- ;; of foreign-name as a string and lisp name as a symbol
--(defmacro def-function (names args &key module returning)
-- #+(or cmu allegro) (declare (ignore module))
-+(defmacro def-function (names args &key module returning calling-convention)
-+ #+(or cmu allegro cormanlisp) (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)))
- (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
-
-- #+allegro
-+ #+allegro ; todo: calling-convention :stdcall
- `(ff:def-foreign-call (,lisp-name ,foreign-name)
- ,function-args
- :returning ,(allegro-convert-return-type result-type)
-@@ -70,7 +69,13 @@
- ,function-args
- ,@(if module (list :module module) (values))
- :result-type ,result-type
-- :calling-convention :cdecl)
-+ :calling-convention ,calling-convention)
-+ #+cormanlisp
-+ `(ct:defun-dll ,lisp-name (,function-args)
-+ :return-type ,result-type
-+ ,@(if module (list :library-name module) (values))
-+ :entry-name ,foreign-name
-+ :linkage-type ,calling-convention) ; we need :pascal
- ))
-
-
---- ./src/primitives.cl~ Tue Apr 9 20:03:25 2002
-+++ ./src/primitives.cl Tue Apr 9 21:05:13 2002
-@@ -29,9 +29,9 @@
- (defmacro def-type (name type)
- "Generates a (deftype) statement for CL. Currently, only CMUCL
- supports takes advantage of this optimization."
-- #+(or lispworks allegro)
-+ #+(or lispworks allegro cormanlisp)
- (declare (ignore type))
-- #+(or lispworks allegro)
-+ #+(or lispworks allegro cormanlisp)
- `(deftype ,name () t)
- #+cmu
- `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
-@@ -45,6 +45,7 @@
- #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
- #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type))
- #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
-+ #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type))
- )
-
- (eval-when (:compile-toplevel :load-toplevel :execute)
-@@ -66,7 +67,7 @@
- (:float . alien:single-float)
- (:double . alien:double-float)
- )
-- "Conversions in CMUCL or def-foreign-type are different thatn in def-function")
-+ "Conversions in CMUCL for def-foreign-type are different that in def-function")
-
-
- #+cmu
-@@ -84,7 +85,7 @@
- (:long . c-call:long) (:unsigned-long . c-call:unsigned-long)
- (:float . c-call:float) (:double . c-call:double)
- (:array . alien:array)))
--#+allegro
-+#+(or allegro cormanlisp)
- (defconstant +type-conversion-list+
- '((* . *) (:void . :void)
- (:short . :short)
-@@ -129,7 +130,7 @@
- "Converts from a uffi type to an implementation specific type"
- (if (atom type)
- (cond
-- #+allegro
-+ #+(or allegro cormanlisp)
- ((and (or (eq context :routine) (eq context :return))
- (eq type :cstring))
- (setq type '((* :char) integer)))
---- ./uffi.system~ Tue Apr 9 20:03:20 2002
-+++ ./uffi.system Tue Apr 9 20:36:14 2002
-@@ -27,7 +27,7 @@
- (merge-pathnames
- (make-pathname
- :directory
-- #+(or cmu allegro lispworks)
-+ #+(or cmu allegro lispworks cormanlisp)
- '(:relative "src")
- #+mcl
- '(:relative "src" "mcl")
-
---------------269CD5B1F75AF20CFDFE4FEE--
-
-_______________________________________________
-UFFI-Devel mailing list
-UFFI-Devel@b9.com
-http://www.b9.com/mailman/listinfo/uffi-devel
-
+++ /dev/null
-SUBDIRS :=
-
-include ../Makefile.common
-
-.PHONY: distclean
-distclean: clean
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: aggregates.cl
-;;;; Purpose: UFFI source to handle aggregate types
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: aggregates.cl,v 1.4 2002/09/30 02:45:24 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-(defmacro def-enum (enum-name args &key (separator-string "#"))
- "Creates a constants for a C type enum list, symbols are created
-in the created in the current package. The symbol is the concatenation
-of the enum-name name, separator-string, and field-name"
- (let ((counter 0)
- (cmds nil)
- (constants nil))
- (declare (fixnum counter))
- (dolist (arg args)
- (let ((name (if (listp arg) (car arg) arg))
- (value (if (listp arg)
- (prog1
- (setq counter (cadr arg))
- (incf counter))
- (prog1
- counter
- (incf counter)))))
- (setq name (intern (concatenate 'string
- (symbol-name enum-name)
- separator-string
- (symbol-name name))))
- (push `(uffi:def-constant ,name ,value) constants)))
- (setf cmds (append '(progn)
- #+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))
- (nreverse constants)))
- cmds))
-
-
-(defmacro def-array-pointer (name-array type)
- #+allegro
- `(ff:def-foreign-type ,name-array
- (:array ,(convert-from-uffi-type type :array)))
- #+lispworks
- `(fli:define-c-typedef ,name-array
- (:c-array ,(convert-from-uffi-type type :array)))
- #+cmu
- `(alien:def-alien-type ,name-array
- (* ,(convert-from-uffi-type type :array)))
- )
-
-(defun process-struct-fields (name fields)
- (let (processed)
- (dolist (field fields)
- (let ((field-name (car field))
- (type (cadr field)))
- (push (append (list field-name)
- (if (eq type :pointer-self)
- #+cmu `((* (alien:struct ,name)))
- #-cmu `((* ,name))
- `(,(convert-from-uffi-type type :struct))))
- processed)))
- (nreverse processed)))
-
-
-(defmacro def-struct (name &rest fields)
- #+cmu
- `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
- #+allegro
- `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
- #+lispworks
- `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
- )
-
-
-(defmacro get-slot-value (obj type slot)
- #+(or lispworks cmu) (declare (ignore type))
- #+allegro
- `(ff:fslot-value-typed ,type :c ,obj ,slot)
- #+lispworks
- `(fli:foreign-slot-value ,obj ,slot)
- #+cmu
- `(alien:slot ,obj ,slot)
- )
-
-(defmacro get-slot-pointer (obj type slot)
- #+(or lispworks cmu) (declare (ignore type))
- #+allegro
- `(ff:fslot-value-typed ,type :c ,obj ,slot)
- #+lispworks
- `(fli:foreign-slot-pointer ,obj ,slot)
- #+cmu
- `(alien:slot ,obj ,slot)
- )
-
-(defmacro deref-array (obj type i)
- "Returns a field from a row"
- #+(or lispworks cmu) (declare (ignore type))
- #+cmu `(alien:deref ,obj ,i)
- #+lispworks `(fli:dereference ,obj :index ,i)
- #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
- )
-
-(defmacro def-union (name &rest fields)
- #+allegro
- `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
- #+lispworks
- `(fli:define-c-union ,name ,@(process-struct-fields name fields))
- #+cmu
- `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
-)
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: function.cl
-;;;; Purpose: UFFI source to C function defintions
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: functions.cl,v 1.1 2002/09/16 17:54:30 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-(defun process-function-args (args)
- (if (null args)
- #+lispworks nil
- #+allegro '(:void)
- #+cmu nil
- (let (processed)
- (dolist (arg args)
- (push (process-one-function-arg arg) processed))
- (nreverse processed))))
-
-(defun process-one-function-arg (arg)
- (let ((name (car arg))
- (type (convert-from-uffi-type (cadr arg) :routine)))
- #+cmu
- (list name type :in)
- #+(or allegro lispworks)
- (if (and (listp type) (listp (car 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
-(defmacro def-function (names args &key module returning)
- #+(or cmu allegro) (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)))
- (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
-
- #+allegro
- `(ff:def-foreign-call (,lisp-name ,foreign-name)
- ,function-args
- :returning ,(allegro-convert-return-type result-type)
- :call-direct t
- :strings-convert nil)
- #+cmu
- `(alien:def-alien-routine (,foreign-name ,lisp-name)
- ,result-type
- ,@function-args)
- #+lispworks
- `(fli:define-foreign-function (,lisp-name ,foreign-name :source)
- ,function-args
- ,@(if module (list :module module) (values))
- :result-type ,result-type
- :calling-convention :cdecl)
- ))
-
-
-(defun make-lisp-name (name)
- (let ((converted (substitute #\- #\_ name)))
- (intern
- #+case-sensitive converted
- #-case-sensitive (string-upcase converted))))
-
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: libraries.cl
-;;;; Purpose: UFFI source to load foreign libraries
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: libraries.cl,v 1.3 2002/09/30 01:57:32 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-(defvar *loaded-libraries* nil
- "List of foreign libraries loaded. Used to prevent reloading a library")
-
-(defun default-foreign-library-type ()
- "Returns string naming default library type for platform"
- #+(or win32 mswindows) "dll"
- #-(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
-string or a list of strings of candidate directories. Use default
-library type if type is not specified."
- (unless types
- (setq types (default-foreign-library-type)))
- (unless (listp types)
- (setq types (list types)))
- (unless (listp names)
- (setq names (list names)))
- (unless (listp directories)
- (setq directories (list directories)))
- #+(or win32 mswindows)
- (unless (listp drive-letters)
- (setq drive-letters (list drive-letters)))
- #-(or win32 mswindows)
- (setq drive-letters '(nil))
- (dolist (drive-letter drive-letters)
- (dolist (name names)
- (dolist (dir directories)
- (dolist (type types)
- (let ((path (make-pathname
- #+lispworks :host
- #+lispworks (when drive-letter drive-letter)
- #-lispworks :device
- #-lispworks (when drive-letter drive-letter)
- :name name
- :type type
- :directory
- (etypecase dir
- (pathname
- (pathname-directory dir))
- (list
- dir)
- (string
- (pathname-directory
- (parse-namestring dir)))))))
- (when (probe-file path)
- (return-from find-foreign-library path)))))))
- nil)
-
-
-(defun load-foreign-library (filename &key module supporting-libraries
- force-load)
- #+allegro (declare (ignore module supporting-libraries))
- #+lispworks (declare (ignore supporting-libraries))
- #+cmu (declare (ignore module))
-
- (when (and filename (probe-file filename))
- (if (pathnamep filename) ;; ensure filename is a string to check if
- (setq filename (namestring filename))) ; already loaded
-
- (if (and (not force-load)
- (find filename *loaded-libraries* :test #'string-equal))
- t ;; return T, but don't reload library
- (progn
- #+cmu
- (let ((type (pathname-type (parse-namestring filename))))
- (if (equal type "so")
- (sys::load-object-file filename)
- (alien:load-foreign filename
- :libraries
- (convert-supporting-libraries-to-string
- supporting-libraries))))
- #+lispworks (fli:register-module module :real-name filename)
- #+allegro (load filename)
- #+openmcl (ccl:open-shared-library filename)
- #+(and mcl (not openmcl)) (ccl:add-to-shared-library-search-path filename t)
-
- (push filename *loaded-libraries*)
- t)))
- )
-
-(defun convert-supporting-libraries-to-string (libs)
- (let (lib-load-list)
- (dolist (lib libs)
- (push (format nil "-l~A" lib) lib-load-list))
- (nreverse lib-load-list)))
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: objects.cl
-;;;; Purpose: UFFI source to handle objects and pointers
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: objects.cl,v 1.1 2002/09/16 17:54:30 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-(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. The TYPE parameter is evaluated."
- (if (eq size :unspecified)
- (progn
- #+cmu
- `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
- #+lispworks
- `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate))
- #+allegro
- `(ff:allocate-fobject ,(convert-from-uffi-type type :allocate) :c))
- (progn
- #+cmu
- `(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)
- #+allegro
- `(ff:allocate-fobject '(:array ,(convert-from-uffi-type (eval type) :allocate) ,(eval size)) :c)
- )
- ))
-
-(defmacro free-foreign-object (obj)
- #+cmu
- `(alien:free-alien ,obj)
- #+lispworks
- `(fli:free-foreign-object ,obj)
- #+allegro
- `(ff:free-fobject ,obj)
- )
-
-(defmacro null-pointer-p (obj)
- #+lispworks `(fli:null-pointer-p ,obj)
- #+allegro `(zerop ,obj)
- #+cmu `(alien:null-alien ,obj)
- )
-
-(defmacro size-of-foreign-type (type)
- #+lispworks `(fli:size-of ,type)
- #+allegro `(ff:sizeof-fobject ,type)
- #+cmu `(alien:alien-size ,type)
- #+clisp `(values (ffi:size-of ,type))
- )
-
-
-(defmacro make-null-pointer (type)
- #+(or allegro cmu) (declare (ignore type))
-
- #+cmu `(system:int-sap 0)
- #+allegro 0
- #+lispworks `(fli:make-pointer :address 0 :type ,type)
- )
-
-(defmacro char-array-to-pointer (obj)
- #+cmu `(alien:cast ,obj (* (alien:unsigned 8)))
- #+lispworks `(fli:make-pointer :type '(:unsigned :char)
- :address (fli:pointer-address ,obj))
- #+allegro obj
- )
-
-(defmacro deref-pointer (ptr type)
- "Returns a object pointed"
- #+(or cmu lispworks) (declare (ignore type))
- #+cmu `(alien:deref ,ptr)
- #+lispworks `(fli:dereference ,ptr)
- #+allegro `(ff:fslot-value-typed ,(convert-from-uffi-type type :deref) :c ,ptr)
-)
-
-#+lispworks ;; with LW, deref is a character
-(defmacro ensure-char-character (obj)
- obj
- )
-
-#+(or allegro cmu)
-(defmacro ensure-char-character (obj)
- `(code-char ,obj)
- )
-
-#+lispworks
-(defmacro ensure-char-integer (obj)
- `(char-code ,obj))
-
-#+(or allegro cmu)
-(defmacro ensure-char-integer (obj)
- obj
- ) ;; (* :char) dereference is already an integer
-
-(defmacro pointer-address (obj)
- #+cmu
- `(system:sap-int (alien:alien-sap ,obj))
- #+lispworks
- `(fli:pointer-address ,obj)
- #+allegro
- obj
- )
-
-;; TYPE is evaluated.
-(defmacro with-foreign-object ((var type) &rest body)
- #-(or cmu lispworks) ; default version
- `(let ((,var (allocate-foreign-object ,type)))
- (unwind-protect
- (progn ,@body)
- (free-foreign-object ,var)))
- #+cmu
- (let ((obj (gensym)))
- `(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
- (eval type) :allocate)))
- ,@body)
- )
-
-
-(defmacro with-foreign-objects (bindings &rest body)
- (if bindings
- `(with-foreign-object ,(car bindings)
- (with-foreign-objects ,(cdr bindings)
- ,@body))
- `(progn ,@body)))
-
-
-
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: package.cl
-;;;; Purpose: Defines UFFI package
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :cl-user)
-
-(defpackage :uffi
- (:use :cl)
- (:export
-
- ;; immediate types
- #:def-constant
- #:def-foreign-type
- #:def-type
- #:null-char-p
-
- ;; aggregate types
- #:def-enum
- #:def-struct
- #:get-slot-value
- #:get-slot-pointer
- #:def-array-pointer
- #:deref-array
- #:def-union
-
- ;; objects
- #:allocate-foreign-object
- #:free-foreign-object
- #:with-foreign-object
- #:with-foreign-objects
- #:size-of-foreign-type
- #:pointer-address
- #:deref-pointer
- #:ensure-char-character
- #:ensure-char-integer
- #:null-pointer-p
- #:make-null-pointer
- #:+null-cstring-pointer+
- #:char-array-to-pointer
-
- ;; string functions
- #:convert-from-cstring
- #:convert-to-cstring
- #:free-cstring
- #:with-cstring
- #:with-cstrings
- #:convert-from-foreign-string
- #:convert-to-foreign-string
- #:allocate-foreign-string
- #:with-foreign-string
-
- ;; function call
- #:def-function
-
- ;; Libraries
- #:find-foreign-library
- #:load-foreign-library
- #:default-foreign-library-type
- ))
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: primitives.cl
-;;;; Purpose: UFFI source to handle immediate types
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: primitives.cl,v 1.3 2002/09/30 02:45:24 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-(defmacro def-constant (name value &key (export nil))
- "Macro to define a constant and to export it"
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant ,name ,value)
- ,(when export (list 'export `(quote ,name)))
- ',name))
-
-(defmacro def-type (name type)
- "Generates a (deftype) statement for CL. Currently, only CMUCL
-supports takes advantage of this optimization."
- #+(or lispworks allegro)
- (declare (ignore type))
- #+(or lispworks allegro)
- `(deftype ,name () t)
- #+cmu
- `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
- #+sbcl
- `(deftype ,name () '(sb-alien:alien ,(convert-from-uffi-type type :declare)))
- )
-
-(defmacro null-char-p (val)
- "Returns T if character is NULL"
- `(zerop ,val))
-
-(defmacro def-foreign-type (name type)
- #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
- #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type))
- #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
- #+sbcl `(sb-alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
- )
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar +type-conversion-hash+ (make-hash-table :size 20))
- #+(or cmu sbcl) (defvar +cmu-def-type-hash+ (make-hash-table :size 20))
- )
-
-#+cmu
-(defconstant +cmu-def-type-list+
- '((:char . (alien:signed 8))
- (:unsigned-char . (alien:unsigned 8))
- (:byte . (alien:signed 8))
- (:unsigned-byte . (alien:unsigned 8))
- (:short . (alien:signed 16))
- (:unsigned-short . (alien:unsigned 16))
- (:int . (alien:signed 32))
- (:unsigned-int . (alien:unsigned 32))
- (:long . (alien:signed 32))
- (:unsigned-long . (alien:unsigned 32))
- (:float . alien:single-float)
- (:double . alien:double-float)
- )
- "Conversions in CMUCL for def-foreign-type are different than in def-function")
-#+sbcl
-(defconstant +cmu-def-type-list+
- '((:char . (sb-alien:signed 8))
- (:unsigned-char . (sb-alien:unsigned 8))
- (:byte . (sb-alien:signed 8))
- (:unsigned-byte . (sb-alien:unsigned 8))
- (:short . (sb-alien:signed 16))
- (:unsigned-short . (sb-alien:unsigned 16))
- (:int . (sb-alien:signed 32))
- (:unsigned-int . (sb-alien:unsigned 32))
- (:long . (sb-alien:signed 32))
- (:unsigned-long . (sb-alien:unsigned 32))
- (:float . sb-alien:single-float)
- (:double . sb-alien:double-float)
- )
- "Conversions in SBCL for def-foreign-type are different than in def-function")
-
-(defparameter +type-conversion-list+ nil)
-
-#+cmu
-(setq +type-conversion-list+
- '((* . *) (:void . c-call:void)
- (:short . c-call:short)
- (:pointer-void . (* t))
- (:cstring . c-call:c-string)
- (:char . c-call:char)
- (:unsigned-char . (alien:unsigned 8))
- (:byte . (alien:signed 8))
- (:unsigned-byte . (alien:unsigned 8))
- (:short . c-call:unsigned-short)
- (:unsigned-short . c-call:unsigned-short)
- (:int . alien:integer) (:unsigned-int . c-call:unsigned-int)
- (:long . c-call:long) (:unsigned-long . c-call:unsigned-long)
- (:float . c-call:float) (:double . c-call:double)
- (:array . alien:array)))
-
-#+sbcl
-(setq +type-conversion-list+
- '((* . *) (:void . void)
- (:short . short)
- (:pointer-void . (* t))
- (:cstring . c-string)
- (:char . char)
- (:unsigned-char . (sb-alien:unsigned 8))
- (:byte . (sb-alien:signed 8))
- (:unsigned-byte . (sb-alien:unsigned 8))
- (:short . unsigned-short)
- (:unsigned-short . unsigned-short)
- (:int . integer) (:unsigned-int . unsigned-int)
- (:long . long) (:unsigned-long . unsigned-long)
- (:float . float) (:double . double)
- (:array . array)))
-
-#+allegro
-(setq +type-conversion-list+
- '((* . *) (:void . :void)
- (:short . :short)
- (:pointer-void . (* :void))
- (:cstring . (* :unsigned-char))
- (:byte . :char)
- (:unsigned-byte . :unsigned-byte)
- (:char . :char)
- (:unsigned-char . :unsigned-char)
- (:int . :int) (:unsigned-int . :unsigned-int)
- (:long . :long) (:unsigned-long . :unsigned-long)
- (:float . :float) (:double . :double)
- (:array . :array)))
-#+lispworks
-(setq +type-conversion-list+
- '((* . :pointer) (:void . :void)
- (:short . :short)
- (:pointer-void . (:pointer :void))
- (:cstring . (:reference-pass (:ef-mb-string :external-format :latin-1)
- :allow-null t))
- (:cstring-returning . (:reference (:ef-mb-string :external-format :latin-1) :allow-null t))
- (:byte . :byte)
- (:unsigned-byte . (:unsigned :byte))
- (:char . :char)
- (:unsigned-char . (:unsigned :char))
- (:int . :int) (:unsigned-int . (:unsigned :int))
- (:long . :long) (:unsigned-long . (:unsigned :long))
- (:float . :float) (:double . :double)
- (:array . :c-array)))
-
-(dolist (type +type-conversion-list+)
- (setf (gethash (car type) +type-conversion-hash+) (cdr type)))
-
-#+(or cmu sbcl)
-(dolist (type +cmu-def-type-list+)
- (setf (gethash (car type) +cmu-def-type-hash+) (cdr type)))
-
-(defun basic-convert-from-uffi-type (type)
- (let ((found-type (gethash type +type-conversion-hash+)))
- (if found-type
- found-type
- type)))
-
-(defun convert-from-uffi-type (type context)
- "Converts from a uffi type to an implementation specific type"
- (if (atom type)
- (cond
- #+allegro
- ((and (or (eq context :routine) (eq context :return))
- (eq type :cstring))
- (setq type '((* :char) integer)))
- #+(or cmu sbcl)
- ((eq context :type)
- (let ((cmu-type (gethash type +cmu-def-type-hash+)))
- (if cmu-type
- cmu-type
- (basic-convert-from-uffi-type type))))
- #+lispworks
- ((and (eq context :return)
- (eq type :cstring))
- (basic-convert-from-uffi-type :cstring-returning))
- (t
- (basic-convert-from-uffi-type type)))
- (let ((sub-type (car type)))
- (case sub-type
- (cl:quote
- (convert-from-uffi-type (cadr type) context))
- (:struct-pointer
- #+openmcl `(:* (:struct ,(convert-from-uffi-type (cadr type) :struct)))
- #-openmcl (convert-from-uffi-type (list '* (cadr type)) :struct)
- )
- (:struct
- #+openmcl `(:struct ,(convert-from-uffi-type (cadr type) :struct))
- #-openmcl (convert-from-uffi-type (cadr type) :struct)
- )
- (t
- (cons (convert-from-uffi-type (first type) context)
- (convert-from-uffi-type (rest type) context)))))))
-
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: strings.cl
-;;;; Purpose: UFFI source to handle strings, cstring and foreigns
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: strings.cl,v 1.2 2002/09/19 03:33:25 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-
-(defvar +null-cstring-pointer+
- #+cmu nil
- #+allegro 0
- #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))
- #-(or cmu allegro lispworks) nil
-)
-
-(defmacro convert-from-cstring (obj)
- "Converts a string from a c-call. Same as convert-from-foreign-string, except
-that LW/CMU automatically converts strings from c-calls."
- #+cmu obj
- #+lispworks obj
- #+allegro
- (let ((stored (gensym)))
- `(let ((,stored ,obj))
- (if (zerop ,stored)
- nil
- (values (excl:native-to-string ,stored)))))
- )
-
-(defmacro convert-to-cstring (obj)
- #+cmu obj
- #+lispworks obj
- #+allegro
- `(if (null ,obj)
- 0
- (values (excl:string-to-native ,obj)))
- )
-
-(defmacro free-cstring (obj)
- #+cmu (declare (ignore obj))
- #+lispworks (declare (ignore obj))
- #+allegro
- `(unless (zerop obj)
- (ff:free-fobject ,obj))
- )
-
-(defmacro with-cstring ((cstring lisp-string) &body body)
- #+cmu
- `(let ((,cstring ,lisp-string)) ,@body)
- #+lispworks
- `(let ((,cstring ,lisp-string)) ,@body)
- #+allegro
- (let ((acl-native (gensym)))
- `(excl:with-native-string (,acl-native ,lisp-string)
- (let ((,cstring (if ,lisp-string ,acl-native 0)))
- ,@body)))
- )
-
-(defmacro with-cstrings (bindings &rest body)
- (if bindings
- `(with-cstring ,(car bindings)
- (with-cstrings ,(cdr bindings)
- ,@body))
- `(progn ,@body)))
-
-;;; Foreign string functions
-
-(defmacro convert-to-foreign-string (obj)
- #+lispworks
- `(if (null ,obj)
- +null-cstring-pointer+
- (fli:convert-to-foreign-string ,obj))
- #+allegro
- `(if (null ,obj)
- 0
- (values (excl:string-to-native ,obj)))
- #+cmu
- (let ((size (gensym))
- (storage (gensym))
- (i (gensym)))
- `(etypecase ,obj
- (null
- (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
- (string
- (let* ((,size (length ,obj))
- (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size))))
- (setq ,storage (alien:cast ,storage (* (alien:unsigned 8))))
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (dotimes (,i ,size)
- (declare (fixnum ,i))
- (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i))))
- (setf (alien:deref ,storage ,size) 0))
- ,storage))))
- )
-
-
-;; Either length or null-terminated-p must be non-nil
-(defmacro convert-from-foreign-string (obj &key
- length
- (null-terminated-p t))
- #+allegro
- `(if (zerop ,obj)
- nil
- (values (excl:native-to-string
- ,obj
- ,@(if length (list :length length) (values))
- :truncate (not ,null-terminated-p))))
- #+lispworks
- `(if (fli:null-pointer-p ,obj)
- nil
- (fli:convert-from-foreign-string
- ,obj
- ,@(if length (list :length length) (values))
- :null-terminated-p ,null-terminated-p
- :external-format '(:latin-1 :eol-style :lf)))
- #+cmu
- `(if (null-pointer-p ,obj)
- nil
- (cmucl-naturalize-cstring (alien:alien-sap ,obj)
- :length ,length
- :null-terminated-p ,null-terminated-p))
- )
-
-
-
-(defmacro allocate-foreign-string (size &key (unsigned t))
- #+cmu
- (let ((array-def (gensym)))
- `(let ((,array-def (list 'alien:array 'c-call:char ,size)))
- (eval `(alien:cast (alien:make-alien ,,array-def)
- ,(if ,unsigned
- '(* (alien:unsigned 8))
- '(* (alien:signed 8)))))))
- #+lispworks
- `(fli:allocate-foreign-object :type
- ,(if unsigned
- ''(:unsigned :char)
- :char)
- :nelems ,size)
- #+allegro
- (declare (ignore unsigned))
- #+allegro
- `(ff:allocate-fobject :char :c ,size)
- )
-
-(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)))
-
-
-;; Modified from CMUCL's source to handle non-null terminated strings
-#+cmu
-(defun cmucl-naturalize-cstring (sap &key
- length
- (null-terminated-p t))
- (declare (type system:system-area-pointer sap))
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (let ((null-terminated-length
- (when null-terminated-p
- (loop
- for offset of-type fixnum upfrom 0
- until (zerop (system:sap-ref-8 sap offset))
- finally (return offset)))))
- (if length
- (if (and null-terminated-length
- (> (the fixnum length) (the fixnum null-terminated-length)))
- (setq length null-terminated-length))
- (setq length null-terminated-length)))
- (let ((result (make-string length)))
- (kernel:copy-from-system-area sap 0
- result (* vm:vector-data-offset
- vm:word-bits)
- (* length vm:byte-bits))
- result)))
+++ /dev/null
-SUBDIRS :=
-
-include ../Makefile.common
-
-.PHONY: distclean
-distclean: clean
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: aggregates.cl
-;;;; Purpose: UFFI source to handle aggregate types
-;;;; Programmers: Kevin M. Rosenberg and John DeSoi
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: aggregates.cl,v 1.3 2002/09/30 01:57:32 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;; and John DeSoi
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-
-
-(defmacro def-enum (enum-name args &key (separator-string "#"))
- "Creates a constants for a C type enum list, symbols are created
-in the created in the current package. The symbol is the concatenation
-of the enum-name name, separator-string, and field-name"
- (let ((counter 0)
- (cmds nil)
- (constants nil))
- (declare (fixnum counter))
- (dolist (arg args)
- (let ((name (if (listp arg) (car arg) arg))
- (value (if (listp arg)
- (prog1
- (setq counter (cadr arg))
- (incf counter))
- (prog1
- counter
- (incf counter)))))
- (setq name (intern (concatenate 'string
- (symbol-name enum-name)
- separator-string
- (symbol-name name))))
- (push `(uffi:def-constant ,name ,value) constants)))
- (setf cmds (append '(progn)
- #+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))
- #-openmcl `((def-mcl-type ,enum-name :integer))
- #+openmcl `((ccl::def-foreign-type ,enum-name :int))
- (nreverse constants)))
- cmds))
-
-
-
-(defmacro def-array-pointer (name-array type)
- #-openmcl
- `(def-mcl-type ,name-array '(:array ,type))
- #+openmcl
- `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array))))
-
-
-
-; 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"
- (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)
- (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)
-
-
-(defun process-struct-fields (name fields variant)
- (let (processed)
- (dolist (field fields)
- (let* ((field-name (car field))
- (type (cadr field))
- (def (append (list field-name)
- (cond
- ((eq type :pointer-self)
- #+cmu `((* (alien:struct ,name)))
- #+openmcl `((:* (:struct ,name)))
- #-(or cmu openmcl) `((* ,name))
- )
- (t
- `(,(convert-from-uffi-type type :struct)))))))
- (if variant
- (push (list def) processed)
- (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" (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
-(def-union union
- (l1 :long)
- (s1 :short))
-
-(def-struct struct
- (s1 :short)
- (l1 :long)
- (u1 :union))
-
-(defvar s (allocate-foreign-object :struct))
-(setf (get-slot-value s :struct :s1) 3)
-(get-slot-value s :struct :s1)
-(setf (get-slot-value s :struct :u1.s1) 5)
-(get-slot-value s :struct :u1.s1)
-
-|#
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: function.cl
-;;;; Purpose: UFFI source to C function defintions
-;;;; Programmers: Kevin M. Rosenberg and John DeSoi
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $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
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(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)
- 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)
- (list name 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)))
- (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (ccl:define-entry-point (,lisp-name ,foreign-name)
- ,function-args
- ,result-type))))
-
-
-
-#+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)))))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: libraries.cl
-;;;; Purpose: UFFI source to load foreign libraries
-;;;; Programmers: Kevin M. Rosenberg and John DeSoi
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: libraries.cl,v 1.4 2002/09/30 01:57:32 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;; and John DeSoi
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-(defvar *loaded-libraries* nil
- "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
-#-openmcl
-(defun 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*))))
-
-
-; 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
-(defun 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
-library type if type is not specified."
- (unless types
- (setq types (default-foreign-library-type)))
- (unless (listp types)
- (setq types (list types)))
- (unless (listp names)
- (setq names (list names)))
- (unless (listp directories)
- (setq directories (list directories)))
- #+(or win32 mswindows)
- (unless (listp drive-letters)
- (setq drive-letters (list drive-letters)))
- #-(or win32 mswindows)
- (setq drive-letters '(nil))
- (dolist (drive-letter drive-letters)
- (dolist (name names)
- (dolist (dir directories)
- (dolist (type types)
- (let ((path (make-pathname
- #+lispworks :host
- #+lispworks (when drive-letter drive-letter)
- #-lispworks :device
- #-lispworks (when drive-letter drive-letter)
- :name name
- :type type
- :directory
- (etypecase dir
- (pathname
- (pathname-directory dir))
- (list
- dir)
- (string
- (pathname-directory
- (parse-namestring dir)))))))
- (when (probe-file path)
- (return-from find-foreign-library path)))))))
- nil)
-
-
-
-(defun default-foreign-library-type ()
- "Returns string naming default library type for platform"
- #+(or win32 mswindows) "dll"
- #-(or win32 mswindows mcl) "so"
- #+openmcl '("dylib" "so" nil)
- #-openmcl '(nil))
-
-
-
-
-
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: objects.cl
-;;;; Purpose: UFFI source to handle objects and pointers
-;;;; Programmers: Kevin M. Rosenberg and John DeSoi
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $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
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-
-;;;
-;;; Some MCL specific utilities
-;;;
-
-; 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 ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))
- `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation))))))
-
-
-
-(defmacro free-foreign-object (obj)
- `(dispose-ptr ,obj))
-
-(defmacro null-pointer-p (obj)
- `(ccl:%null-ptr-p ,obj))
-
-
-(defmacro make-null-pointer (type)
- (declare (ignore type))
- `(ccl:%null-ptr))
-
-
-;already a macptr
-(defmacro char-array-to-pointer (obj)
- obj)
-
-
-(defmacro deref-pointer (ptr type)
- `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref)))
-
-(defmacro deref-pointer-set (ptr type 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 ((params nil) type count)
- (dolist (spec (reverse bindings)) ;keep order - macroexpands to let*
- (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate))
- (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))
-
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: package.cl
-;;;; Purpose: Defines UFFI package
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :cl-user)
-
-(defpackage :uffi
- (:use :cl)
- (:export
-
- ;; immediate types
- #:def-constant
- #:def-foreign-type
- #:def-type
- #:null-char-p
-
- ;; aggregate types
- #:def-enum
- #:def-struct
- #:get-slot-value
- #:get-slot-pointer
- #:def-array-pointer
- #:deref-array
- #:def-union
-
- ;; objects
- #:allocate-foreign-object
- #:free-foreign-object
- #:with-foreign-object
- #:with-foreign-objects
- #:size-of-foreign-type
- #:pointer-address
- #:deref-pointer
- #:ensure-char-character
- #:ensure-char-integer
- #:null-pointer-p
- #:make-null-pointer
- #:+null-cstring-pointer+
- #:char-array-to-pointer
-
- ;; string functions
- #:convert-from-cstring
- #:convert-to-cstring
- #:free-cstring
- #:with-cstring
- #:with-cstrings
- #:convert-from-foreign-string
- #:convert-to-foreign-string
- #:allocate-foreign-string
- #:with-foreign-string
-
- ;; function call
- #:def-function
-
- ;; Libraries
- #:find-foreign-library
- #:load-foreign-library
- #:default-foreign-library-type
- ))
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: primitives.cl
-;;;; Purpose: UFFI source to handle immediate types
-;;;; Programmers: Kevin M. Rosenberg and John DeSoi
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: primitives.cl,v 1.4 2002/09/30 01:57:32 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;; and John DeSoi
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(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 ,(keyword name) (ccl:find-mactype ,type)))
-
-
-(defmacro def-constant (name value &key (export nil))
- "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))))
-
-(defmacro def-type (name type)
- "Generates a (deftype) statement for CL. Currently, only CMUCL
-supports takes advantage of this optimization."
- (declare (ignore type))
- `(deftype ,name () t))
-
-(defmacro null-char-p (val)
- "Returns T if character is NULL"
- `(zerop ,val))
-
-
-(defmacro def-foreign-type (name uffi-type)
- (let ((type (convert-from-uffi-type uffi-type :type)))
- (unless (or (keywordp type) (consp 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) (:unsigned-short . :unsigned-short)
- (:pointer-void . :pointer)
- (:cstring . :string)
- (:char . :character)
- (:unsigned-char . :unsigned-byte)
- (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
- (:int . :long) (:unsigned-int . :unsigned-long)
- (:long . :long) (:unsigned-long . :unsigned-long)
- (:float . :single-float) (:double . :double-float)
- (:array . :array)))
-
-#+openmcl
-(defconstant +type-conversion-list+
- '((* . :address) (:void . :void)
- (:short . :short) (:unsigned-short . :unsigned-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 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)))
- (let ((sub-type (car type)))
- (case sub-type
- (cl:quote
- (%convert-from-uffi-type (cadr type) context))
- (:struct-pointer
- #+openmcl `(:* (:struct ,(convert-from-uffi-type (cadr type) :struct)))
- #-openmcl `(,(convert-from-uffi-type (list '* (cadr type)) :struct))
- )
- (:struct
- #+openmcl `(:struct ,(convert-from-uffi-type (cadr type) :struct))
- #-openmcl `(,(convert-from-uffi-type (cadr type) :struct))
- )
- (t
- (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)
- (if (eq context :struct)
- (append '(:*) (cdr result))
- :address))
- #-openmcl
- ((and (eq (car result) :pointer) (eq context :allocation) :pointer))
- (t result))))
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: strings.cl
-;;;; Purpose: UFFI source to handle strings, cstring and foreigns
-;;;; Programmers: Kevin M. Rosenberg and John DeSoi
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: strings.cl,v 1.3 2002/09/29 18:54:17 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;; and John DeSoi
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-
-(defvar +null-cstring-pointer+ (ccl:%null-ptr))
-
-(defmacro convert-from-cstring (obj)
- "Converts a string from a c-call. Same as convert-from-foreign-string, except
-that CMU automatically converts strings from c-calls."
- #+cmu obj
- #+lispworks
- (let ((stored (gensym)))
- `(let ((,stored ,obj))
- (if (fli:null-pointer-p ,stored)
- nil
- (fli:convert-from-foreign-string ,stored))))
- #+allegro
- (let ((stored (gensym)))
- `(let ((,stored ,obj))
- (if (zerop ,stored)
- nil
- (values (excl:native-to-string ,stored)))))
- #+mcl
- (let ((stored (gensym)))
- `(let ((,stored ,obj))
- (if (ccl:%null-ptr-p ,stored)
- nil
- (values (ccl:%get-cstring ,stored)))))
-
-
- )
-
-(defmacro convert-to-cstring (obj)
- #+lispworks
- `(if (null ,obj)
- +null-cstring-pointer+
- (fli:convert-to-foreign-string ,obj))
- #+allegro
- `(if (null ,obj)
- 0
- (values (excl:string-to-native ,obj)))
- #+cmu
- (declare (ignore obj))
- #+mcl
- `(if (null ,obj)
- +null-cstring-pointer+
- (let ((ptr (new-ptr (1+ (length ,obj)))))
- (ccl:%put-cstring ptr ,obj)
- ptr))
- )
-
-(defmacro free-cstring (obj)
- #+lispworks
- `(unless (fli:null-pointer-p ,obj)
- (fli:free-foreign-object ,obj))
- #+allegro
- `(unless (zerop obj)
- (ff:free-fobject ,obj))
- #+cmu
- (declare (ignore obj))
- #+mcl
- `(unless (ccl:%null-ptr-p ,obj)
- (dispose-ptr ,obj))
-
- )
-
-;; Either length or null-terminated-p must be non-nil
-(defmacro convert-from-foreign-string (obj &key
- length
- (null-terminated-p t))
- #+allegro
- `(if (zerop ,obj)
- nil
- (values (excl:native-to-string
- ,obj
- ,@(if length (list :length length) (values))
- :truncate (not ,null-terminated-p))))
- #+lispworks
- `(if (fli:null-pointer-p ,obj)
- nil
- (fli:convert-from-foreign-string
- ,obj
- ,@(if length (list :length length) (values))
- :null-terminated-p ,null-terminated-p
- :external-format '(:latin-1 :eol-style :lf)))
- #+cmu
- `(cmucl-naturalize-cstring (alien:alien-sap ,obj)
- :length ,length
- :null-terminated-p ,null-terminated-p)
- #+mcl
- (declare (ignore null-terminated-p))
- #+mcl
- `(if (ccl:%null-ptr-p ,obj)
- nil
- (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil)))
- )
-
-(defmacro convert-to-foreign-string (obj)
- #+lispworks
- `(if (null ,obj)
- +null-cstring-pointer+
- (fli:convert-to-foreign-string ,obj))
- #+allegro
- `(if (null ,obj)
- 0
- (values (excl:string-to-native ,obj)))
- #+cmu
- (let ((size (gensym))
- (storage (gensym))
- (i (gensym)))
- `(when (stringp ,obj)
- (let* ((,size (length ,obj))
- (,storage (alien:make-alien char (1+ ,size))))
- (setq ,storage (alien:cast ,storage (* char)))
- (dotimes (,i ,size)
- (declare (fixnum ,i)
- (optimize (speed 3) (safety 0)))
- (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i))))
- (setf (alien:deref ,storage ,size) 0)
- ,storage)))
- #+mcl
- `(if (null ,obj)
- +null-cstring-pointer+
- (let ((ptr (new-ptr (1+ (length ,obj)))))
- (ccl:%put-cstring ptr ,obj)
- ptr))
- )
-
-
-(defmacro allocate-foreign-string (size &key (unsigned t))
- #+cmu
- (let ((array-def (gensym)))
- `(let ((,array-def (list 'alien:array 'c-call:char ,size)))
- (eval `(alien:cast (alien:make-alien ,,array-def)
- ,(if ,unsigned
- '(* (alien:unsigned 8))
- '(* (alien:signed 8)))))))
- #+lispworks
- `(fli:allocate-foreign-object :type
- ,(if unsigned
- ''(:unsigned :char)
- :char)
- :nelems ,size)
- #+allegro
- (declare (ignore unsigned))
- #+allegro
- `(ff:allocate-fobject :char :c ,size)
- #+mcl
- (declare (ignore unsigned))
- #+mcl
- `(new-ptr ,size)
-
- )
-
-
-; I'm sure there must be a better way to write this...
-(defmacro with-cstring ((foreign-string lisp-string) &body body)
- `(if (stringp ,lisp-string)
- (ccl:with-cstrs ((,foreign-string ,lisp-string))
- ,@body)
- (let ((,foreign-string +null-cstring-pointer+))
- ,@body)))
-
-
-(defmacro with-cstrings (bindings &rest body)
- (if bindings
- `(with-cstring ,(car bindings)
- (with-cstrings ,(cdr bindings)
- ,@body))
- `(progn ,@body)))
-
-(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)))
-
-
-
-
-
--- /dev/null
+SUBDIRS :=
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: aggregates.cl
+;;;; Purpose: UFFI source to handle aggregate types
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: aggregates.cl,v 1.14 2002/09/30 07:51:01 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+(defmacro def-enum (enum-name args &key (separator-string "#"))
+ "Creates a constants for a C type enum list, symbols are created
+in the created in the current package. The symbol is the concatenation
+of the enum-name name, separator-string, and field-name"
+ (let ((counter 0)
+ (cmds nil)
+ (constants nil))
+ (declare (fixnum counter))
+ (dolist (arg args)
+ (let ((name (if (listp arg) (car arg) arg))
+ (value (if (listp arg)
+ (prog1
+ (setq counter (cadr arg))
+ (incf counter))
+ (prog1
+ counter
+ (incf counter)))))
+ (setq name (intern (concatenate 'string
+ (symbol-name enum-name)
+ separator-string
+ (symbol-name name))))
+ (push `(uffi:def-constant ,name ,value) constants)))
+ (setf cmds (append '(progn)
+ #+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))
+ #+(and mcl (not openmcl)) `((def-mcl-type ,enum-name :integer))
+ #+openmcl `((ccl::def-foreign-type ,enum-name :int))
+ (nreverse constants)))
+ cmds))
+
+
+(defmacro def-array-pointer (name-array type)
+ #+allegro
+ `(ff:def-foreign-type ,name-array
+ (:array ,(convert-from-uffi-type type :array)))
+ #+lispworks
+ `(fli:define-c-typedef ,name-array
+ (:c-array ,(convert-from-uffi-type type :array)))
+ #+cmu
+ `(alien:def-alien-type ,name-array
+ (* ,(convert-from-uffi-type type :array)))
+ #+(and mcl (not openmcl))
+ `(def-mcl-type ,name-array '(:array ,type))
+ #+openmcl
+ `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
+ )
+
+(defun process-struct-fields (name fields)
+ (let (processed)
+ (dolist (field fields)
+ (let ((field-name (car field))
+ (type (cadr field)))
+ (push (append (list field-name)
+ (if (eq type :pointer-self)
+ #+cmu `((* (alien:struct ,name)))
+ #+mcl `((:* (:struct ,name)))
+ #-(or cmu mcl) `((* ,name))
+ `(,(convert-from-uffi-type type :struct))))
+ processed)))
+ (nreverse processed)))
+
+
+(defmacro def-struct (name &rest fields)
+ #+cmu
+ `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
+ #+allegro
+ `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
+ #+lispworks
+ `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
+ #+(and mcl (not openmcl))
+ `(ccl:defrecord ,name ,@(process-struct-fields name fields nil))
+ #+openmcl
+ `(ccl::def-foreign-type nil
+ (:struct ,name ,@(process-struct-fields name fields nil)))
+ )
+
+
+(defmacro get-slot-value (obj type slot)
+ #+(or lispworks cmu) (declare (ignore type))
+ #+allegro
+ `(ff:fslot-value-typed ,type :c ,obj ,slot)
+ #+lispworks
+ `(fli:foreign-slot-value ,obj ,slot)
+ #+cmu
+ `(alien:slot ,obj ,slot)
+ #+mcl
+ `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
+ )
+
+#+mcl
+(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))
+
+#+mcl
+(defsetf get-slot-value set-slot-value)
+
+
+(defmacro get-slot-pointer (obj type slot)
+ #+(or lispworks cmu) (declare (ignore type))
+ #+allegro
+ `(ff:fslot-value-typed ,type :c ,obj ,slot)
+ #+lispworks
+ `(fli:foreign-slot-pointer ,obj ,slot)
+ #+cmu
+ `(alien:slot ,obj ,slot)
+ #+(and mcl (not openmcl))
+ `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))
+ #+openmcl
+ `(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)))))
+)
+
+; so we could allow '(:array :long) or deref with other type like :long only
+#+mcl
+(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"
+ #+(or lispworks cmu) (declare (ignore type))
+ #+cmu `(alien:deref ,obj ,i)
+ #+lispworks `(fli:dereference ,obj :index ,i)
+ #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
+ #+mcl
+ (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
+#+mcl
+(defmacro deref-array-set (obj type i value)
+ (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)))
+
+#+mcl
+(defsetf deref-array deref-array-set)
+
+(defmacro def-union (name &rest fields)
+ #+allegro
+ `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
+ #+lispworks
+ `(fli:define-c-union ,name ,@(process-struct-fields name fields))
+ #+cmu
+ `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
+ #+(and mcl (not openmcl))
+ `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
+ #+openmcl
+ `(ccl::def-foreign-type nil
+ (:union ,name ,@(process-struct-fields name fields nil)))
+)
--- /dev/null
+some notes:
+ we need the :pascal (:stdcall) calling conventions for
+ (def-function names args &key module returning calling-convention)
+ so I added this. calling-convention defaults to :cdecl
+ but on win32 we mostly use :stdcall
+
+ #+corman is invalid, #+cormanlisp instead
+
+ cormanlisp doesn't need to load and register the dll, since the underlying
+ LoadLibrary() call does this. we need the module keyword for def-function
+instead.
+ (should probably default to kernel32.dll)
+ I'll think about library.cl, but we'll need more real-world win32 examples.
+ (ideally the complete winapi :)
+ I also have to look at valentina.
+
+patch -p0 < corman.diff
+--
+Reini Urban
+http://xarch.tu-graz.ac.at/home/rurban/
+--------------269CD5B1F75AF20CFDFE4FEE
+Content-Type: text/plain; charset=us-ascii; name="corman.diff"
+Content-Disposition: inline; filename="corman.diff"
+Content-Transfer-Encoding: 7bit
+
+--- ./examples/getenv-ccl.cl~ Tue Apr 9 21:08:18 2002
++++ ./examples/getenv-ccl.cl Tue Apr 9 20:58:16 2002
+@@ -0,0 +1,87 @@
++;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
++;;;; *************************************************************************
++;;;; FILE IDENTIFICATION
++;;;;
++;;;; Name: getenv-ccl.cl
++;;;; Purpose: cormanlisp version
++;;;; Programmer: "Joe Marshall" <prunesquallor@attbi.com>
++;;;; Date Started: Feb 2002
++;;;;
++;;;; $Id: corman-uffi.cl,v 1.5 2002/09/30 07:52:34 kevin Exp $
++;;;;
++;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
++;;;;
++;;;; UFFI users are granted the rights to distribute and use this software
++;;;; as governed by the terms of the Lisp Lesser GNU Public License
++;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
++;;;; *************************************************************************
++
++(in-package :cl-user)
++
++(ct:defun-dll c-getenv ((lpname LPSTR)
++ (lpbuffer LPSTR)
++ (nsize LPDWORD))
++ :library-name "kernel32.dll"
++ :return-type DWORD
++ :entry-name "GetEnvironmentVariableA"
++ :linkage-type :pascal)
++
++(defun getenv (name)
++ (let ((nsizebuf (ct:malloc (sizeof :long)))
++ (buffer (ct:malloc 1))
++ (cname (ct:lisp-string-to-c-string name)))
++ (setf (ct:cref lpdword nsizebuf 0) 0)
++ (let* ((needed-size (c-getenv cname buffer nsizebuf))
++ (buffer1 (ct:malloc (1+ needed-size))))
++ (setf (ct:cref lpdword nsizebuf 0) needed-size)
++ (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf))
++ nil
++ (ct:c-string-to-lisp-string buffer1))
++ (ct:free buffer1)
++ (ct:free nsizebuf)))))
++
++(defun cl:user-homedir-pathname (&optional host)
++ (cond ((or (stringp host)
++ (and (consp host)
++ (every #'stringp host))) nil)
++ ((or (eq host :unspecific)
++ (null host))
++ (let ((homedrive (getenv "HOMEDRIVE"))
++ (homepath (getenv "HOMEPATH")))
++ (parse-namestring
++ (if (and (stringp homedrive)
++ (stringp homepath)
++ (= (length homedrive) 2)
++ (> (length homepath) 0))
++ (concatenate 'string homedrive homepath "\\")
++ "C:\\"))))
++ (t (error "HOST must be a string, list of strings, NIL or :unspecific"))))
++
++;|
++(uffi:def-function ("getenv" c-getenv)
++ ((name :cstring))
++ :returning :cstring)
++
++(defun my-getenv (key)
++ "Returns an environment variable, or NIL if it does not exist"
++ (check-type key string)
++ (uffi:with-cstring (key-native key)
++ (uffi:convert-from-cstring (c-getenv key-native))))
++
++#+examples-uffi
++(progn
++ (flet ((print-results (str)
++ (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
++ (print-results "USER")
++ (print-results "_FOO_")))
++
++
++#+test-uffi
++(progn
++ (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
++ (util.test:test (and (stringp (my-getenv "USER"))
++ (< 0 (length (my-getenv "USER"))))
++ t :fail-info "Error retrieving getenv")
++)
++
++|;
+\ No newline at end of file
+--- ./Makefile~ Tue Apr 9 20:03:18 2002
++++ ./Makefile Tue Apr 9 20:38:03 2002
+@@ -64,3 +64,7 @@
+
+ wwwdist: dist
+ @./copy
++
++TAGS:
++ if [ -f TAGS ]; then mv -f TAGS TAGS~; fi
++ find . -name \*.cl -exec /usr/bin/etags -a \{\} \;
+--- ./set-logical.cl~ Tue Apr 9 20:03:20 2002
++++ ./set-logical.cl Tue Apr 9 20:35:44 2002
+@@ -35,10 +35,10 @@
+ #+clisp "clisp"
+ #+cmu "cmucl"
+ #+sbcl "sbcl"
+- #+corman "corman"
++ #+cormanlisp "cormanlisp"
+ #+mcl "mcl"
+ #+openmcl "openmcl"
+- #-(or allegro lispworks clisp cmu sbcl corman mcl openmcl) "unknown")
++ #-(or allegro lispworks clisp cmu sbcl cormanlisp mcl openmcl) "unknown")
+
+ (defun set-logical-host-for-pathname (host base-pathname)
+ (setf (logical-pathname-translations host)
+--- ./src/functions.cl~ Tue Apr 9 20:03:24 2002
++++ ./src/functions.cl Tue Apr 9 21:00:07 2002
+@@ -3,7 +3,7 @@
+ ;;;; FILE IDENTIFICATION
+ ;;;;
+ ;;;; Name: function.cl
+-;;;; Purpose: UFFI source to C function defintions
++;;;; Purpose: UFFI source to C function definitions
+ ;;;; Programmer: Kevin M. Rosenberg
+ ;;;; Date Started: Feb 2002
+ ;;;;
+@@ -21,9 +21,8 @@
+
+ (defun process-function-args (args)
+ (if (null args)
+- #+lispworks nil
++ #+(or lispworks cmu cormanlisp) nil
+ #+allegro '(:void)
+- #+cmu nil
+ (let (processed)
+ (dolist (arg args)
+ (push (process-one-function-arg arg) processed))
+@@ -34,7 +33,7 @@
+ (type (convert-from-uffi-type (cadr arg) :routine)))
+ #+cmu
+ (list name type :in)
+- #+(or allegro lispworks)
++ #+(or allegro lispworks cormanlisp)
+ (if (and (listp type) (listp (car type)))
+ (append (list name) type)
+ (list name type))
+@@ -47,15 +46,15 @@
+
+ ;; name is either a string representing foreign name, or a list
+ ;; of foreign-name as a string and lisp name as a symbol
+-(defmacro def-function (names args &key module returning)
+- #+(or cmu allegro) (declare (ignore module))
++(defmacro def-function (names args &key module returning calling-convention)
++ #+(or cmu allegro cormanlisp) (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)))
+ (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
+
+- #+allegro
++ #+allegro ; todo: calling-convention :stdcall
+ `(ff:def-foreign-call (,lisp-name ,foreign-name)
+ ,function-args
+ :returning ,(allegro-convert-return-type result-type)
+@@ -70,7 +69,13 @@
+ ,function-args
+ ,@(if module (list :module module) (values))
+ :result-type ,result-type
+- :calling-convention :cdecl)
++ :calling-convention ,calling-convention)
++ #+cormanlisp
++ `(ct:defun-dll ,lisp-name (,function-args)
++ :return-type ,result-type
++ ,@(if module (list :library-name module) (values))
++ :entry-name ,foreign-name
++ :linkage-type ,calling-convention) ; we need :pascal
+ ))
+
+
+--- ./src/primitives.cl~ Tue Apr 9 20:03:25 2002
++++ ./src/primitives.cl Tue Apr 9 21:05:13 2002
+@@ -29,9 +29,9 @@
+ (defmacro def-type (name type)
+ "Generates a (deftype) statement for CL. Currently, only CMUCL
+ supports takes advantage of this optimization."
+- #+(or lispworks allegro)
++ #+(or lispworks allegro cormanlisp)
+ (declare (ignore type))
+- #+(or lispworks allegro)
++ #+(or lispworks allegro cormanlisp)
+ `(deftype ,name () t)
+ #+cmu
+ `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
+@@ -45,6 +45,7 @@
+ #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
+ #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type))
+ #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
++ #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type))
+ )
+
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+@@ -66,7 +67,7 @@
+ (:float . alien:single-float)
+ (:double . alien:double-float)
+ )
+- "Conversions in CMUCL or def-foreign-type are different thatn in def-function")
++ "Conversions in CMUCL for def-foreign-type are different that in def-function")
+
+
+ #+cmu
+@@ -84,7 +85,7 @@
+ (:long . c-call:long) (:unsigned-long . c-call:unsigned-long)
+ (:float . c-call:float) (:double . c-call:double)
+ (:array . alien:array)))
+-#+allegro
++#+(or allegro cormanlisp)
+ (defconstant +type-conversion-list+
+ '((* . *) (:void . :void)
+ (:short . :short)
+@@ -129,7 +130,7 @@
+ "Converts from a uffi type to an implementation specific type"
+ (if (atom type)
+ (cond
+- #+allegro
++ #+(or allegro cormanlisp)
+ ((and (or (eq context :routine) (eq context :return))
+ (eq type :cstring))
+ (setq type '((* :char) integer)))
+--- ./uffi.system~ Tue Apr 9 20:03:20 2002
++++ ./uffi.system Tue Apr 9 20:36:14 2002
+@@ -27,7 +27,7 @@
+ (merge-pathnames
+ (make-pathname
+ :directory
+- #+(or cmu allegro lispworks)
++ #+(or cmu allegro lispworks cormanlisp)
+ '(:relative "src")
+ #+mcl
+ '(:relative "src" "mcl")
+
+--------------269CD5B1F75AF20CFDFE4FEE--
+
+_______________________________________________
+UFFI-Devel mailing list
+UFFI-Devel@b9.com
+http://www.b9.com/mailman/listinfo/uffi-devel
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: function.cl
+;;;; Purpose: UFFI source to C function defintions
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: functions.cl,v 1.10 2002/09/30 07:51:01 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+(defun process-function-args (args)
+ (if (null args)
+ #+lispworks nil
+ #+allegro '(:void)
+ #+cmu nil
+ #+(and mcl (not openmcl)) nil
+ #+mcl (values nil nil)
+
+ ;; args not null
+ #+(or lispworks allegro cmu (and mcl (not openmcl)))
+ (let (processed)
+ (dolist (arg args)
+ (push (process-one-function-arg arg) processed))
+ (nreverse processed))
+ #+openmcl
+ (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)))
+ ))
+
+(defun process-one-function-arg (arg)
+ (let ((name (car arg))
+ (type (convert-from-uffi-type (cadr arg) :routine)))
+ #+cmu
+ (list name type :in)
+ #+(or allegro lispworks (and mcl (not openmcl)))
+ (if (and (listp type) (listp (car 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
+(defmacro def-function (names args &key module returning)
+ #+(or cmu allegro mcl) (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)))
+ (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
+
+ #+allegro
+ `(ff:def-foreign-call (,lisp-name ,foreign-name)
+ ,function-args
+ :returning ,(allegro-convert-return-type result-type)
+ :call-direct t
+ :strings-convert nil)
+ #+cmu
+ `(alien:def-alien-routine (,foreign-name ,lisp-name)
+ ,result-type
+ ,@function-args)
+ #+lispworks
+ `(fli:define-foreign-function (,lisp-name ,foreign-name :source)
+ ,function-args
+ ,@(if module (list :module module) (values))
+ :result-type ,result-type
+ :calling-convention :cdecl)
+ #+(and mcl (not openmcl))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (ccl:define-entry-point (,lisp-name ,foreign-name)
+ ,function-args
+ ,result-type))
+ #+(and openmcl darwinppc-target)
+ (setf foreign-name (concatenate 'string "_" foreign-name))
+ #+openmcl
+ (multiple-value-bind (params args) (process-function-args args)
+ `(defun ,lisp-name ,params
+ (ccl::external-call ,foreign-name ,@args ,result-type)))
+ ))
+
+
+(defun make-lisp-name (name)
+ (let ((converted (substitute #\- #\_ name)))
+ (intern
+ #+case-sensitive converted
+ #-case-sensitive (string-upcase converted))))
+
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: libraries.cl
+;;;; Purpose: UFFI source to load foreign libraries
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: libraries.cl,v 1.18 2002/09/30 07:51:01 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+(defvar *loaded-libraries* nil
+ "List of foreign libraries loaded. Used to prevent reloading a library")
+
+(defun default-foreign-library-type ()
+ "Returns string naming default library type for platform"
+ #+(or win32 mswindows) "dll"
+ #+macosx "dylib"
+ #-(or win32 mswindows macosx) "so"
+)
+
+(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
+library type if type is not specified."
+ (unless types
+ (setq types (default-foreign-library-type)))
+ (unless (listp types)
+ (setq types (list types)))
+ (unless (listp names)
+ (setq names (list names)))
+ (unless (listp directories)
+ (setq directories (list directories)))
+ #+(or win32 mswindows)
+ (unless (listp drive-letters)
+ (setq drive-letters (list drive-letters)))
+ #-(or win32 mswindows)
+ (setq drive-letters '(nil))
+ (dolist (drive-letter drive-letters)
+ (dolist (name names)
+ (dolist (dir directories)
+ (dolist (type types)
+ (let ((path (make-pathname
+ #+lispworks :host
+ #+lispworks (when drive-letter drive-letter)
+ #-lispworks :device
+ #-lispworks (when drive-letter drive-letter)
+ :name name
+ :type type
+ :directory
+ (etypecase dir
+ (pathname
+ (pathname-directory dir))
+ (list
+ dir)
+ (string
+ (pathname-directory
+ (parse-namestring dir)))))))
+ (when (probe-file path)
+ (return-from find-foreign-library path)))))))
+ nil)
+
+
+(defun load-foreign-library (filename &key module supporting-libraries
+ force-load)
+ #+allegro (declare (ignore module supporting-libraries))
+ #+lispworks (declare (ignore supporting-libraries))
+ #+cmu (declare (ignore module))
+ #+openmcl (declare (ignore module supporting-libraries))
+
+ (when (and filename (probe-file filename))
+ (if (pathnamep filename) ;; ensure filename is a string to check if
+ (setq filename (namestring filename))) ; already loaded
+
+ (if (and (not force-load)
+ (find filename *loaded-libraries* :test #'string-equal))
+ t ;; return T, but don't reload library
+ (progn
+ (when
+ #+cmu
+ (let ((type (pathname-type (parse-namestring filename))))
+ (if (equal type "so")
+ (sys::load-object-file filename)
+ (alien:load-foreign filename
+ :libraries
+ (convert-supporting-libraries-to-string
+ supporting-libraries))))
+ #+lispworks (fli:register-module module :real-name filename)
+ #+allegro (load filename)
+ #+openmcl (ccl:open-shared-library filename)
+ #+(and mcl (not openmcl)) (ccl:add-to-shared-library-search-path filename t)
+
+ (push filename *loaded-libraries*)
+ t)))))
+
+(defun convert-supporting-libraries-to-string (libs)
+ (let (lib-load-list)
+ (dolist (lib libs)
+ (push (format nil "-l~A" lib) lib-load-list))
+ (nreverse lib-load-list)))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: readmacros-mcl.cl
+;;;; Purpose: UFFI source to handle objects and pointers
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: objects-mcl.cl,v 1.1 2002/09/30 07:51:01 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+;; trap macros don't work right directly in the macros
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ #+(and mcl (not openmcl))
+ (defun new-ptr (size)
+ (#_NewPtr size))
+
+ #+(and mcl (not openmcl))
+ (defun dispose-ptr (ptr)
+ (#_DisposePtr ptr))
+
+ #+openmcl
+ (defmacro new-ptr (size)
+ `(ccl::malloc ,size))
+
+ #+openmcl
+ (defmacro dispose-ptr (ptr)
+ `(ccl::free ,ptr))
+ )
+
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: objects.cl
+;;;; Purpose: UFFI source to handle objects and pointers
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: objects.cl,v 1.24 2002/09/30 07:51:01 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+(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. The TYPE parameter is evaluated."
+ (if (eq size :unspecified)
+ (progn
+ #+cmu
+ `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
+ #+lispworks
+ `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate))
+ #+allegro
+ `(ff:allocate-fobject ,(convert-from-uffi-type type :allocate) :c)
+ #+mcl
+ `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))
+ )
+ (progn
+ #+cmu
+ `(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)
+ #+allegro
+ `(ff:allocate-fobject '(:array ,(convert-from-uffi-type (eval type) :allocate) ,(eval size)) :c)
+ #+mcl
+ `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation))))
+ )))
+
+(defmacro free-foreign-object (obj)
+ #+cmu
+ `(alien:free-alien ,obj)
+ #+lispworks
+ `(fli:free-foreign-object ,obj)
+ #+allegro
+ `(ff:free-fobject ,obj)
+ #+mcl
+ `(dispose-ptr ,obj)
+ )
+
+(defmacro null-pointer-p (obj)
+ #+lispworks `(fli:null-pointer-p ,obj)
+ #+allegro `(zerop ,obj)
+ #+cmu `(alien:null-alien ,obj)
+ #+mcl `(ccl:%null-ptr-p ,obj)
+ )
+
+(defmacro size-of-foreign-type (type)
+ #+lispworks `(fli:size-of ,type)
+ #+allegro `(ff:sizeof-fobject ,type)
+ #+cmu `(alien:alien-size ,type)
+ #+clisp `(values (ffi:size-of ,type))
+ #+(and mcl (not 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
+ #+opencml `(ccl::%foreign-type-or-record-size ,type :bytes)
+ )
+
+
+(defmacro make-null-pointer (type)
+ #+(or allegro cmu mcl) (declare (ignore type))
+
+ #+cmu `(system:int-sap 0)
+ #+allegro 0
+ #+lispworks `(fli:make-pointer :address 0 :type ,type)
+ #+mcl `(ccl:%null-ptr)
+ )
+
+(defmacro char-array-to-pointer (obj)
+ #+cmu `(alien:cast ,obj (* (alien:unsigned 8)))
+ #+lispworks `(fli:make-pointer :type '(:unsigned :char)
+ :address (fli:pointer-address ,obj))
+ #+allegro obj
+ #+mcl obj
+ )
+
+(defmacro deref-pointer (ptr type)
+ "Returns a object pointed"
+ #+(or cmu lispworks) (declare (ignore type))
+ #+cmu `(alien:deref ,ptr)
+ #+lispworks `(fli:dereference ,ptr)
+ #+allegro `(ff:fslot-value-typed ,(convert-from-uffi-type type :deref) :c ,ptr)
+ #+mcl `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref))
+ )
+
+#+mcl
+(defmacro deref-pointer-set (ptr type value)
+ `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value))
+
+#+mcl
+(defsetf deref-pointer deref-pointer-set)
+
+#+(or lispworks (and mcl (not openmcl))) ;; with LW, deref is a character
+(defmacro ensure-char-character (obj)
+ obj)
+
+#+(or allegro cmu openmcl)
+(defmacro ensure-char-character (obj)
+ `(code-char ,obj))
+
+#+(or lispworks (and mcl (not openmcl)))
+(defmacro ensure-char-integer (obj)
+ `(char-code ,obj))
+
+#+(or allegro cmu openmcl)
+(defmacro ensure-char-integer (obj)
+ obj)
+
+(defmacro pointer-address (obj)
+ #+cmu
+ `(system:sap-int (alien:alien-sap ,obj))
+ #+lispworks
+ `(fli:pointer-address ,obj)
+ #+allegro
+ obj
+ #+mcl
+ `(ccl:%ptr-to-int ,obj)
+ )
+
+;; TYPE is evaluated.
+#-mcl
+(defmacro with-foreign-object ((var type) &rest body)
+ #-(or cmu lispworks) ; default version
+ `(let ((,var (allocate-foreign-object ,type)))
+ (unwind-protect
+ (progn ,@body)
+ (free-foreign-object ,var)))
+ #+cmu
+ (let ((obj (gensym)))
+ `(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
+ (eval type) :allocate)))
+ ,@body)
+ )
+
+#+mcl
+(defmacro with-foreign-object ((var type) &rest body)
+ `(with-foreign-objects ((,var ,type))
+ ,@body))
+
+#-mcl
+(defmacro with-foreign-objects (bindings &rest body)
+ (if bindings
+ `(with-foreign-object ,(car bindings)
+ (with-foreign-objects ,(cdr bindings)
+ ,@body))
+ `(progn ,@body)))
+
+#+mcl
+(defmacro with-foreign-objects (bindings &rest body)
+ (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))
+ (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)))
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: package.cl
+;;;; Purpose: Defines UFFI package
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :cl-user)
+
+(defpackage :uffi
+ (:use :cl)
+ (:export
+
+ ;; immediate types
+ #:def-constant
+ #:def-foreign-type
+ #:def-type
+ #:null-char-p
+
+ ;; aggregate types
+ #:def-enum
+ #:def-struct
+ #:get-slot-value
+ #:get-slot-pointer
+ #:def-array-pointer
+ #:deref-array
+ #:def-union
+
+ ;; objects
+ #:allocate-foreign-object
+ #:free-foreign-object
+ #:with-foreign-object
+ #:with-foreign-objects
+ #:size-of-foreign-type
+ #:pointer-address
+ #:deref-pointer
+ #:ensure-char-character
+ #:ensure-char-integer
+ #:null-pointer-p
+ #:make-null-pointer
+ #:+null-cstring-pointer+
+ #:char-array-to-pointer
+
+ ;; string functions
+ #:convert-from-cstring
+ #:convert-to-cstring
+ #:free-cstring
+ #:with-cstring
+ #:with-cstrings
+ #:convert-from-foreign-string
+ #:convert-to-foreign-string
+ #:allocate-foreign-string
+ #:with-foreign-string
+
+ ;; function call
+ #:def-function
+
+ ;; Libraries
+ #:find-foreign-library
+ #:load-foreign-library
+ #:default-foreign-library-type
+ ))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: primitives.cl
+;;;; Purpose: UFFI source to handle immediate types
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: primitives.cl,v 1.24 2002/09/30 07:51:01 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+#+mcl
+(defvar *keyword-package* (find-package "KEYWORD"))
+
+#+mcl
+; 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
+#+(and mcl (not openmcl))
+(defmacro def-mcl-type (name type)
+ `(ccl::def-mactype ,(keyword name) (ccl:find-mactype ,type)))
+
+(defmacro def-constant (name value &key (export nil))
+ "Macro to define a constant and to export it"
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant ,name ,value)
+ ,(when export (list 'export `(quote ,name)))
+ ',name))
+
+(defmacro def-type (name type)
+ "Generates a (deftype) statement for CL. Currently, only CMUCL
+supports takes advantage of this optimization."
+ #+(or lispworks allegro mcl)
+ (declare (ignore type))
+ #+(or lispworks allegro mcl)
+ `(deftype ,name () t)
+ #+cmu
+ `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
+ #+sbcl
+ `(deftype ,name () '(sb-alien:alien ,(convert-from-uffi-type type :declare)))
+ )
+
+(defmacro null-char-p (val)
+ "Returns T if character is NULL"
+ `(zerop ,val))
+
+(defmacro def-foreign-type (name type)
+ #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
+ #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type))
+ #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
+ #+sbcl `(sb-alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
+ #+mcl
+ (let ((type (convert-from-uffi-type uffi-type :type)))
+ (unless (or (keywordp type) (consp type))
+ (setf type `(quote ,type)))
+ #+(and mcl (not 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))
+ #+(or cmu sbcl) (defvar +cmu-def-type-hash+ (make-hash-table :size 20))
+ )
+
+#+cmu
+(defconstant +cmu-def-type-list+
+ '((:char . (alien:signed 8))
+ (:unsigned-char . (alien:unsigned 8))
+ (:byte . (alien:signed 8))
+ (:unsigned-byte . (alien:unsigned 8))
+ (:short . (alien:signed 16))
+ (:unsigned-short . (alien:unsigned 16))
+ (:int . (alien:signed 32))
+ (:unsigned-int . (alien:unsigned 32))
+ (:long . (alien:signed 32))
+ (:unsigned-long . (alien:unsigned 32))
+ (:float . alien:single-float)
+ (:double . alien:double-float)
+ )
+ "Conversions in CMUCL for def-foreign-type are different than in def-function")
+#+sbcl
+(defconstant +cmu-def-type-list+
+ '((:char . (sb-alien:signed 8))
+ (:unsigned-char . (sb-alien:unsigned 8))
+ (:byte . (sb-alien:signed 8))
+ (:unsigned-byte . (sb-alien:unsigned 8))
+ (:short . (sb-alien:signed 16))
+ (:unsigned-short . (sb-alien:unsigned 16))
+ (:int . (sb-alien:signed 32))
+ (:unsigned-int . (sb-alien:unsigned 32))
+ (:long . (sb-alien:signed 32))
+ (:unsigned-long . (sb-alien:unsigned 32))
+ (:float . sb-alien:single-float)
+ (:double . sb-alien:double-float)
+ )
+ "Conversions in SBCL for def-foreign-type are different than in def-function")
+
+(defparameter +type-conversion-list+ nil)
+
+#+cmu
+(setq +type-conversion-list+
+ '((* . *) (:void . c-call:void)
+ (:short . c-call:short)
+ (:pointer-void . (* t))
+ (:cstring . c-call:c-string)
+ (:char . c-call:char)
+ (:unsigned-char . (alien:unsigned 8))
+ (:byte . (alien:signed 8))
+ (:unsigned-byte . (alien:unsigned 8))
+ (:short . c-call:unsigned-short)
+ (:unsigned-short . c-call:unsigned-short)
+ (:int . alien:integer) (:unsigned-int . c-call:unsigned-int)
+ (:long . c-call:long) (:unsigned-long . c-call:unsigned-long)
+ (:float . c-call:float) (:double . c-call:double)
+ (:array . alien:array)))
+
+#+sbcl
+(setq +type-conversion-list+
+ '((* . *) (:void . void)
+ (:short . short)
+ (:pointer-void . (* t))
+ (:cstring . c-string)
+ (:char . char)
+ (:unsigned-char . (sb-alien:unsigned 8))
+ (:byte . (sb-alien:signed 8))
+ (:unsigned-byte . (sb-alien:unsigned 8))
+ (:short . unsigned-short)
+ (:unsigned-short . unsigned-short)
+ (:int . integer) (:unsigned-int . unsigned-int)
+ (:long . long) (:unsigned-long . unsigned-long)
+ (:float . float) (:double . double)
+ (:array . array)))
+
+#+allegro
+(setq +type-conversion-list+
+ '((* . *) (:void . :void)
+ (:short . :short)
+ (:pointer-void . (* :void))
+ (:cstring . (* :unsigned-char))
+ (:byte . :char)
+ (:unsigned-byte . :unsigned-byte)
+ (:char . :char)
+ (:unsigned-char . :unsigned-char)
+ (:int . :int) (:unsigned-int . :unsigned-int)
+ (:long . :long) (:unsigned-long . :unsigned-long)
+ (:float . :float) (:double . :double)
+ (:array . :array)))
+
+#+lispworks
+(setq +type-conversion-list+
+ '((* . :pointer) (:void . :void)
+ (:short . :short)
+ (:pointer-void . (:pointer :void))
+ (:cstring . (:reference-pass (:ef-mb-string :external-format :latin-1)
+ :allow-null t))
+ (:cstring-returning . (:reference (:ef-mb-string :external-format :latin-1) :allow-null t))
+ (:byte . :byte)
+ (:unsigned-byte . (:unsigned :byte))
+ (:char . :char)
+ (:unsigned-char . (:unsigned :char))
+ (:int . :int) (:unsigned-int . (:unsigned :int))
+ (:long . :long) (:unsigned-long . (:unsigned :long))
+ (:float . :float) (:double . :double)
+ (:array . :c-array)))
+
+#+(and mcl (not openmcl))
+(defconstant +type-conversion-list+
+ '((* . :pointer) (:void . :void)
+ (:short . :short) (:unsigned-short . :unsigned-short)
+ (:pointer-void . :pointer)
+ (:cstring . :string)
+ (:char . :character)
+ (:unsigned-char . :unsigned-byte)
+ (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
+ (:int . :long) (:unsigned-int . :unsigned-long)
+ (:long . :long) (:unsigned-long . :unsigned-long)
+ (:float . :single-float) (:double . :double-float)
+ (:array . :array)))
+
+#+openmcl
+(defconstant +type-conversion-list+
+ '((* . :address) (:void . :void)
+ (:short . :short) (:unsigned-short . :unsigned-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)))
+
+#+(or cmu sbcl)
+(dolist (type +cmu-def-type-list+)
+ (setf (gethash (car type) +cmu-def-type-hash+) (cdr type)))
+
+(defun basic-convert-from-uffi-type (type)
+ (let ((found-type (gethash type +type-conversion-hash+)))
+ (if found-type
+ found-type
+ #-mcl type
+ #+mcl (keyword type))))
+
+(defun %convert-from-uffi-type (type context)
+ "Converts from a uffi type to an implementation specific type"
+ (if (atom type)
+ (cond
+ #+allegro
+ ((and (or (eq context :routine) (eq context :return))
+ (eq type :cstring))
+ (setq type '((* :char) integer)))
+ #+(or cmu sbcl)
+ ((eq context :type)
+ (let ((cmu-type (gethash type +cmu-def-type-hash+)))
+ (if cmu-type
+ cmu-type
+ (basic-convert-from-uffi-type type))))
+ #+lispworks
+ ((and (eq context :return)
+ (eq type :cstring))
+ (basic-convert-from-uffi-type :cstring-returning))
+ #+(and mcl (not openmcl))
+ ((and (eq type :void) (eq context :return)) nil)
+ (t
+ (basic-convert-from-uffi-type type)))
+ (let ((sub-type (car type)))
+ (case sub-type
+ (cl:quote
+ (convert-from-uffi-type (cadr type) context))
+ (:struct-pointer
+ #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
+ #-mcl (%convert-from-uffi-type (list '* (cadr type)) :struct)
+ )
+ (:struct
+ #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
+ #-mcl (%convert-from-uffi-type (cadr type) :struct)
+ )
+ (t
+ (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)
+ (if (eq context :struct)
+ (append '(:*) (cdr result))
+ :address))
+ #+(and mcl (not openmcl))
+ ((and (eq (car result) :pointer) (eq context :allocation) :pointer))
+ (t result))))
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: readmacros-mcl.cl
+;;;; Purpose: This file holds functions using read macros for MCL
+;;;; Programmer: Kevin M. Rosenberg/John Desoi
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: readmacros-mcl.cl,v 1.1 2002/09/30 07:56:21 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+
+;; trap macros don't work right directly in the macros
+#+(and mcl (not openmcl))
+(defun new-ptr (size)
+ (#_NewPtr size))
+
+#+(and mcl (not openmcl))
+(defun dispose-ptr (ptr)
+ (#_DisposePtr ptr))
+
+#+openmcl
+(defmacro new-ptr (size)
+ `(ccl::malloc ,size))
+
+#+openmcl
+(defmacro dispose-ptr (ptr)
+ `(ccl::free ,ptr))
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: readmacros-mcl.cl
+;;;; Purpose: This file holds functions using read macros for MCL
+;;;; Programmer: Kevin M. Rosenberg/John Desoi
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: readmacros-mcl.lisp,v 1.1 2002/09/30 07:51:01 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+
+;; trap macros don't work right directly in the macros
+#+(and mcl (not openmcl))
+(defun new-ptr (size)
+ (#_NewPtr size))
+
+#+(and mcl (not openmcl))
+(defun dispose-ptr (ptr)
+ (#_DisposePtr ptr))
+
+#+openmcl
+(defmacro new-ptr (size)
+ `(ccl::malloc ,size))
+
+#+openmcl
+(defmacro dispose-ptr (ptr)
+ `(ccl::free ,ptr))
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: strings.cl
+;;;; Purpose: UFFI source to handle strings, cstring and foreigns
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: strings.cl,v 1.22 2002/09/30 07:51:01 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :uffi)
+
+
+(defvar +null-cstring-pointer+
+ #+cmu nil
+ #+allegro 0
+ #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))
+ #+mcl (ccl:%nul-ptr)
+ #-(or cmu allegro lispworks mcl) nil
+)
+
+(defmacro convert-from-cstring (obj)
+ "Converts a string from a c-call. Same as convert-from-foreign-string, except
+that LW/CMU automatically converts strings from c-calls."
+ #+cmu obj
+ #+lispworks obj
+ #+allegro
+ (let ((stored (gensym)))
+ `(let ((,stored ,obj))
+ (if (zerop ,stored)
+ nil
+ (values (excl:native-to-string ,stored)))))
+ #+mcl
+ (let ((stored (gensym)))
+ `(let ((,stored ,obj))
+ (if (ccl:%null-ptr-p ,stored)
+ nil
+ (values (ccl:%get-cstring ,stored)))))
+ )
+
+(defmacro convert-to-cstring (obj)
+ #+cmu obj
+ #+lispworks obj
+ #+allegro
+ `(if (null ,obj)
+ 0
+ (values (excl:string-to-native ,obj)))
+ #+mcl
+ `(if (null ,obj)
+ +null-cstring-pointer+
+ (let ((ptr (new-ptr (1+ (length ,obj)))))
+ (ccl:%put-cstring ptr ,obj)
+ ptr))
+ )
+
+(defmacro free-cstring (obj)
+ #+cmu (declare (ignore obj))
+ #+lispworks (declare (ignore obj))
+ #+allegro
+ `(unless (zerop obj)
+ (ff:free-fobject ,obj))
+ #+mcl
+ `(unless (ccl:%null-ptr-p ,obj)
+ (dispose-ptr ,obj))
+ )
+
+(defmacro with-cstring ((cstring lisp-string) &body body)
+ #+cmu
+ `(let ((,cstring ,lisp-string)) ,@body)
+ #+lispworks
+ `(let ((,cstring ,lisp-string)) ,@body)
+ #+allegro
+ (let ((acl-native (gensym)))
+ `(excl:with-native-string (,acl-native ,lisp-string)
+ (let ((,cstring (if ,lisp-string ,acl-native 0)))
+ ,@body)))
+ #+mcl
+ `(if (stringp ,lisp-string)
+ (ccl:with-cstrs ((,foreign-string ,lisp-string))
+ ,@body)
+ (let ((,foreign-string +null-cstring-pointer+))
+ ,@body))
+ )
+
+(defmacro with-cstrings (bindings &rest body)
+ (if bindings
+ `(with-cstring ,(car bindings)
+ (with-cstrings ,(cdr bindings)
+ ,@body))
+ `(progn ,@body)))
+
+;;; Foreign string functions
+
+(defmacro convert-to-foreign-string (obj)
+ #+lispworks
+ `(if (null ,obj)
+ +null-cstring-pointer+
+ (fli:convert-to-foreign-string ,obj))
+ #+allegro
+ `(if (null ,obj)
+ 0
+ (values (excl:string-to-native ,obj)))
+ #+cmu
+ (let ((size (gensym))
+ (storage (gensym))
+ (i (gensym)))
+ `(etypecase ,obj
+ (null
+ (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
+ (string
+ (let* ((,size (length ,obj))
+ (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size))))
+ (setq ,storage (alien:cast ,storage (* (alien:unsigned 8))))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (dotimes (,i ,size)
+ (declare (fixnum ,i))
+ (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i))))
+ (setf (alien:deref ,storage ,size) 0))
+ ,storage))))
+ #+mcl
+ `(if (null ,obj)
+ +null-cstring-pointer+
+ (let ((ptr (new-ptr (1+ (length ,obj)))))
+ (ccl:%put-cstring ptr ,obj)
+ ptr))
+ )
+
+
+;; Either length or null-terminated-p must be non-nil
+(defmacro convert-from-foreign-string (obj &key
+ length
+ (null-terminated-p t))
+ #+allegro
+ `(if (zerop ,obj)
+ nil
+ (values (excl:native-to-string
+ ,obj
+ ,@(if length (list :length length) (values))
+ :truncate (not ,null-terminated-p))))
+ #+lispworks
+ `(if (fli:null-pointer-p ,obj)
+ nil
+ (fli:convert-from-foreign-string
+ ,obj
+ ,@(if length (list :length length) (values))
+ :null-terminated-p ,null-terminated-p
+ :external-format '(:latin-1 :eol-style :lf)))
+ #+cmu
+ `(if (null-pointer-p ,obj)
+ nil
+ (cmucl-naturalize-cstring (alien:alien-sap ,obj)
+ :length ,length
+ :null-terminated-p ,null-terminated-p))
+ #+mcl
+ (declare (ignore null-terminated-p))
+ #+mcl
+ `(if (ccl:%null-ptr-p ,obj)
+ nil
+ (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil)))
+ )
+
+
+
+(defmacro allocate-foreign-string (size &key (unsigned t))
+ #+cmu
+ (let ((array-def (gensym)))
+ `(let ((,array-def (list 'alien:array 'c-call:char ,size)))
+ (eval `(alien:cast (alien:make-alien ,,array-def)
+ ,(if ,unsigned
+ '(* (alien:unsigned 8))
+ '(* (alien:signed 8)))))))
+ #+lispworks
+ `(fli:allocate-foreign-object :type
+ ,(if unsigned
+ ''(:unsigned :char)
+ :char)
+ :nelems ,size)
+ #+allegro
+ (declare (ignore unsigned))
+ #+allegro
+ `(ff:allocate-fobject :char :c ,size)
+ #+mcl
+ (declare (ignore unsigned))
+ #+mcl
+ `(new-ptr ,size)
+ )
+
+(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)))
+
+
+;; Modified from CMUCL's source to handle non-null terminated strings
+#+cmu
+(defun cmucl-naturalize-cstring (sap &key
+ length
+ (null-terminated-p t))
+ (declare (type system:system-area-pointer sap))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let ((null-terminated-length
+ (when null-terminated-p
+ (loop
+ for offset of-type fixnum upfrom 0
+ until (zerop (system:sap-ref-8 sap offset))
+ finally (return offset)))))
+ (if length
+ (if (and null-terminated-length
+ (> (the fixnum length) (the fixnum null-terminated-length)))
+ (setq length null-terminated-length))
+ (setq length null-terminated-length)))
+ (let ((result (make-string length)))
+ (kernel:copy-from-system-area sap 0
+ result (* vm:vector-data-offset
+ vm:word-bits)
+ (* length vm:byte-bits))
+ result)))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Aug 2002
;;;;
-;;;; $Id: uffi.asd,v 1.15 2002/09/25 12:44:59 kevin Exp $
+;;;; $Id: uffi.asd,v 1.16 2002/09/30 07:51:00 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
(in-package :asdf)
-#+(or allegro lispworks cmu openmcl mcl)
+#+(or allegro lispworks cmu mcl)
(defsystem uffi
:name "cl-uffi"
:author "Kevin M. Rosenberg <kmr@debian.org>"
(pushnew :uffi cl:*features*))
:components
- (
- #+(or cmu sbcl allegro lispworks)
- (:module :src-main
- :components
- ((:file "package")
- (:file "primitives" :depends-on ("package"))
- (:file "strings" :depends-on ("primitives"))
- (:file "objects" :depends-on ("primitives"))
- (:file "aggregates" :depends-on ("primitives"))
- (:file "functions" :depends-on ("primitives"))
- (:file "libraries" :depends-on ("package"))))
- #+mcl
- (:module :src-mcl
- :components
- ((:file "package")
- (:file "primitives" :depends-on ("package"))
- (:file "strings" :depends-on ("primitives"))
- (:file "objects" :depends-on ("primitives"))
- (:file "aggregates" :depends-on ("primitives"))
- (:file "functions" :depends-on ("primitives"))
- (:file "libraries" :depends-on ("package"))))
+ ((:module :src
+ :components
+ ((:file "package")
+ (:file "primitives" :depends-on ("package"))
+ #+mcl (:file "readmacros-mcl" :depends-on ("package"))
+ (:file "strings" :depends-on ("primitives"))
+ (:file "objects" :depends-on ("primitives"))
+ (:file "aggregates" :depends-on ("primitives"))
+ (:file "functions" :depends-on ("primitives"))
+ (:file "libraries" :depends-on ("package"))))
#+cormanlisp
(:module :src-corman
:components
))
-#+(or allegro lispworks cmu openmcl mcl)
+#+(or allegro lispworks cmu mcl)
(defmethod source-file-type ((c cl-source-file) (s (eql (find-system :uffi))))
"cl")
-#+(or allegro lispworks cmu openmcl mcl)
+#+(or allegro lispworks cmu mcl)
(when (ignore-errors (find-class 'load-compiled-op))
(defmethod perform :after ((op load-compiled-op) (c (eql (find-system :uffi))))
(pushnew :uffi cl:*features*)))
projects / uffi.git / commitdiff