+2002-09-16 Kevin Rosenberg (kevin@rosenberg.net)
+ - Restructure directories to move to a asdf definition file
+ without pathnames.
+
2002-08-25 Kevin Rosenberg (kevin@rosenberg.net)
- Restructure directories to attempt to properly handle both
Common Lisp Controller and non-CLC systems
dh_testroot
dh_clean -k
dh_installdirs --all $(clc-systems) $(clc-source)
- dh_installdirs -p $(debpkg) $(doc-dir) $(clc-uffi)/mcl
+ dh_installdirs -p $(debpkg) $(doc-dir) $(clc-uffi)/src $(clc-uffi)/src-mcl
# Add here commands to install the package into debian/uffi.
- dh_install uffi.system uffi.asd $(clc-systems)
- dh_install "uffi/*.cl" $(clc-uffi)
- dh_install "uffi/mcl/*.cl" $(clc-uffi)/mcl
+ dh_install uffi.asd $(clc-uffi)
+ dh_install "src/*.cl" $(clc-uffi)/src
+ dh_install "src-mcl/*.cl" $(clc-uffi)/src-mcl
+ dh_link $(clc-uffi)/uffi.asd $(clc-systems)/uffi.asd
rm -rf doc/html
(cd doc; tar xzf html.tar.gz; cd ..)
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: set-logical.cl
-;;;; Purpose: Sets a logical host for src/binaries based on a pathname.
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; CLSQL 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.
-;;;; *************************************************************************
-
-
-;;; Setup logical pathname translaton with separate binary directories
-;;; for each implementation
-
-;; push allegro case sensitivity on *features*
-#+allegro
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (if (or (eq excl:*current-case-mode* :case-sensitive-lower)
- (eq excl:*current-case-mode* :case-sensitive-upper))
- (pushnew :case-sensitive cl:*features*)
- (pushnew :case-insensitive cl:*features*)))
-
-(defconstant +set-logical-compiler-name+
- #+(and allegro ics case-sensitive) "acl-modern"
- #+(and allegro (not ics) case-sensitive) "acl-modern8"
- #+(and allegro ics (not case-sensitive)) "acl-ansi"
- #+(and allegro (not ics) (not case-sensitive)) "acl-ansi8"
- #+lispworks "lispworks"
- #+clisp "clisp"
- #+cmu "cmucl"
- #+sbcl "sbcl"
- #+corman "corman"
- #+mcl "mcl"
- #+openmcl "openmcl"
- #-(or allegro lispworks clisp cmu sbcl corman mcl openmcl) "unknown")
-
-(defun set-logical-host-for-pathname (host base-pathname)
- (setf (logical-pathname-translations host)
- `(("ROOT;" ,(make-pathname
- :host (pathname-host base-pathname)
- :device (pathname-device base-pathname)
- :directory (pathname-directory base-pathname)))
- ("**;*.cl.*" ,(merge-pathnames
- (make-pathname
- :name :wild
- :type :wild
- :directory '(:relative :wild-inferiors))
- base-pathname))
- ("**;*.lisp.*" ,(merge-pathnames
- (make-pathname
- :name :wild
- :type :wild
- :directory '(:relative :wild-inferiors))
- base-pathname))
- ("**;*.c.*" ,(merge-pathnames
- (make-pathname
- :name :wild
- :type :wild
- :directory '(:relative :wild-inferiors))
- base-pathname))
- ("**;*.h.*" ,(merge-pathnames
- (make-pathname
- :name :wild
- :type :wild
- :directory '(:relative :wild-inferiors))
- base-pathname))
- ("**;bin;*.*.*" ,(merge-pathnames
- (make-pathname
- :name :wild
- :type :wild
- :directory
- (append '(:relative :wild-inferiors
- ".bin" #.+set-logical-compiler-name+)))
- base-pathname))
- ;; default is to place in .bin/<compiler> directory
- ("**;*.*.*" ,(merge-pathnames
- (make-pathname
- :name :wild
- :type :wild
- :directory
- (append '(:relative :wild-inferiors
- ".bin" #.+set-logical-compiler-name+)))
- base-pathname)))))
-
--- /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.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 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 ,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.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)
+
+(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) "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))
+
+ (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)
+
+ (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.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 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)))
+ (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.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)
+
+
+(def-constant +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.1 2002/09/16 17:57:43 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))
+ #+mcl `((def-mcl-type ,enum-name :integer))
+ (nreverse constants)))
+ cmds))
+
+
+
+(defmacro def-array-pointer (name-array type)
+ `(def-mcl-type ,name-array '(:array ,type)))
+
+
+; this is how rref expands array slot access (minus adding the struct offset)
+(defmacro deref-array (obj type i)
+ "Returns a field from a row"
+ `(,(accessor-symbol type :get) ,obj (* (the fixnum ,i) ,(foreign-object-size type))))
+
+(defmacro deref-array-set (obj type i value)
+ `(,(accessor-symbol type :set) ,obj ,value (* (the fixnum ,i) ,(foreign-object-size type))))
+
+(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)
+ (if (eq type :pointer-self)
+ #+cmu `((* (alien:struct ,name)))
+ #-cmu `((* ,name))
+ `(,(convert-from-uffi-type type :struct))))))
+ (if variant
+ (push (list def) processed)
+ (push def processed))))
+ (nreverse processed)))
+
+
+(defmacro def-struct (name &rest fields)
+ `(ccl:defrecord ,name ,@(process-struct-fields name fields nil)))
+
+
+(defmacro def-union (name &rest fields)
+ `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t))))
+
+
+; Assuming everything is pointer based - no support for Mac handles
+(defmacro get-slot-value (obj type slot) ;use setf to set values
+ `(ccl:pref ,obj ,(read-from-string (format nil "~a.~a" type slot))))
+
+
+(defmacro get-slot-pointer (obj type slot)
+ `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot)))))
+
+
+
+#| 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)
+
+|#
\ No newline at end of file
--- /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.1 2002/09/16 17:57:43 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 process-function-args (args)
+ (if (null args)
+ #+lispworks nil
+ #+allegro '(:void)
+ #+cmu nil
+ #+mcl nil
+ (let (processed)
+ (dolist (arg args)
+ (push (process-one-function-arg arg) processed))
+ (nreverse processed))))
+
+(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))
+ ))
+
+(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)
+ (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))))
+
+
+(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
+;;;; Programmers: Kevin M. Rosenberg and John DeSoi
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: libraries.cl,v 1.1 2002/09/16 17:57:43 kevin Exp $
+;;;;
+;;;; 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
+(defmacro load-foreign-library (filename &key module supporting-libraries)
+ (declare (ignore module supporting-libraries))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (ccl:add-to-shared-library-search-path ,filename t)
+ (pushnew ,filename *loaded-libraries*))))
+
+;; Copied directly from main source without MCL specializations
+(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)
+
+
+;; Copied directly from main source without MCL specializations
+(defun default-foreign-library-type ()
+ "Returns string naming default library type for platform"
+ #+(or win32 mswindows) "dll"
+ #-(or win32 mswindows) "so")
\ No newline at end of file
--- /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.1 2002/09/16 17:57:43 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
+;;;
+(defun foreign-object-size (type)
+ "Returns the size for the specified mcl type or record type"
+ (let ((mcl-type (ccl:find-mactype type nil t)))
+ (if mcl-type
+ (ccl::mactype-record-size mcl-type)
+ (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)) ) ) ) ;error if not a record
+
+
+; trap macros don't work right directly in the macros
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defun new-ptr (size)
+ (#_NewPtr size))
+
+(defun dispose-ptr (ptr)
+ (#_DisposePtr ptr))
+
+)
+
+;;;
+;;; Start of standard 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."
+ (if (eq size :unspecified)
+ `(new-ptr ,(foreign-object-size (convert-from-uffi-type type :allocation)))
+ `(new-ptr ,(* size (foreign-object-size (convert-from-uffi-type type :allocation))))))
+
+
+
+(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))
+
+
+;! need to check uffi update and see if :routine is the right context
+
+(defun accessor-symbol (type get-or-set)
+ "Returns the symbol used to access the foreign type."
+ (let* ((mcl-type (convert-from-uffi-type (eval type) :routine))
+ (mac-type (ccl:find-mactype mcl-type))
+ name)
+ (ecase get-or-set
+ (:get (setf name (ccl::mactype-get-function mac-type)))
+ (:set (setf name (ccl::mactype-set-function mac-type))))
+ (find-symbol (symbol-name name) :ccl)))
+
+(defmacro deref-pointer (ptr type)
+ `(,(accessor-symbol type :get) ,ptr))
+
+
+(defmacro deref-pointer-set (ptr type value)
+ `(,(accessor-symbol type :set) ,ptr ,value))
+
+
+(defsetf deref-pointer deref-pointer-set)
+
+
+(defmacro pointer-address (obj)
+ `(ccl:%ptr-to-int ,obj))
+
+
+(defmacro with-foreign-objects (bindings &rest body)
+ (let ((simple nil) (recs nil) type)
+ (dolist (spec (reverse bindings)) ;keep order - macroexpands to let*
+ (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate))
+ (if (ccl:mactype-p type)
+ (push (list (first spec) (foreign-object-size type)) simple)
+ (push spec recs)))
+ (cond ((and simple recs)
+ `(ccl:%stack-block ,simple
+ (ccl:rlet ,recs
+ ,@body)))
+ (simple `(ccl:%stack-block ,simple ,@body))
+ (recs `(ccl:rlet ,recs ,@body)))))
+
+
+(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
+ #: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
+ #:load-foreign-library
+
+ ;; Utilities
+ ))
--- /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.1 2002/09/16 17:57:43 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)
+
+; Wrapper for unexported function we have to use
+(defmacro def-mcl-type (name type)
+ `(ccl::def-mactype (quote ,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 type)
+ `(def-mcl-type ,name (convert-from-uffi-type ,type :type)))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar +type-conversion-hash+ (make-hash-table :size 20)))
+
+
+(defconstant +type-conversion-list+
+ '((* . :pointer) (:void . :void)
+ (:short . :short)
+ (:pointer-void . :pointer)
+ (:cstring . :string)
+ (:char . :character)
+ (:unsigned-char . :unsigned-byte)
+ (:byte . :byte)
+ (:int . :integer) (:unsigned-int . :unsigned-integer)
+ (:long . :long) (:unsigned-long . :unsigned-long)
+ (:float . :single-float) (:double . :double-float)
+ (:array . :array)))
+
+(dolist (type +type-conversion-list+)
+ (setf (gethash (car type) +type-conversion-hash+) (cdr type)))
+
+
+(defmethod ph (&optional (os *standard-output*))
+ (maphash #'(lambda (k v) (format os "~&~S => ~S" k v)) +type-conversion-hash+))
+
+(defun convert-from-uffi-type (type context)
+ "Converts from a uffi type to an implementation specific type"
+ (if (atom type)
+ (cond
+ #+mcl
+ ((and (eq type :void) (eq context :return)) nil)
+ (t
+ (let ((found-type (gethash type +type-conversion-hash+)))
+ (if found-type
+ found-type
+ type))))
+ (cons (convert-from-uffi-type (first type) context)
+ (convert-from-uffi-type (rest type) context))))
+
+
+
+
+
+
--- /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.1 2002/09/16 17:57:43 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)))
+
+
+#| Works but, supposedly the built in method is better
+(defmacro with-cstring ((foreign-string lisp-string) &body body)
+ (let ((result (gensym)))
+ `(let* ((,foreign-string (convert-to-cstring ,lisp-string))
+ (,result ,@body))
+ (dispose-ptr ,foreign-string)
+ ,result))
+ )
+
+|#
+
+
+
+
+
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Aug 2002
;;;;
-;;;; $Id: uffi.asd,v 1.9 2002/09/06 11:01:53 kevin Exp $
+;;;; $Id: uffi.asd,v 1.10 2002/09/16 17:57:43 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)
-;; For use with non-Common Lisp Controller installations
-#-common-lisp-controller
-(let ((path (make-pathname :name "set-logical" :type "cl"
- :defaults *load-truename*)))
- (when (probe-file path)
- (load path)
- (set-logical-host-for-pathname
- "uffi"
- (make-pathname :host (pathname-host *load-truename*)
- :device (pathname-device *load-truename*)
- :directory (pathname-directory *load-truename*)))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant +uffi-logical-host+
- #+common-lisp-controller "cl-library"
- #-common-lisp-controller "uffi"
- "Logical hostname for loading system"))
-
(defsystem uffi
:name "cl-uffi"
:author "Kevin M. Rosenberg <kmr@debian.org"
- :version "0.6.1"
+ :version "0.7.0"
:maintainer "Kevin M. Rosenberg <kmr@debian.org"
:licence "Lessor Lisp General Public License"
:description "Universal Foreign Function Library for Common Lisp"
:long-description "UFFI provides a universal foreign function interface (FFI) for Common Lisp. UFFI supports CMUCL, Lispworks, and AllegroCL."
- :pathname
- #-mcl #.(format nil "~A:uffi;" +uffi-logical-host+)
- #+mcl #.(format nil "~A:uffi;mcl;" +uffi-logical-host+)
:perform (load-op :after (op uffi)
- (pushnew :uffi cl:*features*))
- :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")))
- )
+ (pushnew :uffi cl:*features*))
+
+ :components
+ (
+ #+(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"))))
+ #+cormanlisp
+ (:module :src-corman
+ :components
+ ((:file "uffi-corman")))
+ ))
(defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'uffi))))
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: uffi.system
-;;;; Purpose: Defsystem-3/4 system definition file for UFFI package
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: uffi.system,v 1.19 2002/08/23 19:46:16 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 :make)
-
-;; For use with non-Common Lisp Controller installations
-#-common-lisp-controller
-(let ((path (make-pathname :name "set-logical" :type "cl"
- :defaults *load-truename*)))
- (when (probe-file path)
- (load path)
- (set-logical-host-for-pathname
- "uffi"
- (make-pathname :host (pathname-host *load-truename*)
- :device (pathname-device *load-truename*)
- :directory (pathname-directory *load-truename*)))))
-
-(defconstant +uffi-logical-host+
- #+common-lisp-controller "cl-library"
- #-common-lisp-controller "uffi"
- "Logical hostname for loading system")
-
-(make:defsystem :uffi
- :source-pathname
- #-mcl #.(format nil "~A:uffi;" +uffi-logical-host+)
- #+mcl #.(format nil "~A:uffi;mcl;" +uffi-logical-host+)
- :source-extension "cl"
- :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")))
- :finally-do
- (pushnew :uffi cl:*features*))
+++ /dev/null
-SUBDIRS := mcl
-
-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.3 2002/08/23 19:21:54 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 ,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
-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.3 2002/08/23 19:21:54 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.3 2002/08/23 19:21:54 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/08/23 19:21:54 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) "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))
-
- (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)
-
- (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
-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/08/23 19:21:54 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))
- #+mcl `((def-mcl-type ,enum-name :integer))
- (nreverse constants)))
- cmds))
-
-
-
-(defmacro def-array-pointer (name-array type)
- `(def-mcl-type ,name-array '(:array ,type)))
-
-
-; this is how rref expands array slot access (minus adding the struct offset)
-(defmacro deref-array (obj type i)
- "Returns a field from a row"
- `(,(accessor-symbol type :get) ,obj (* (the fixnum ,i) ,(foreign-object-size type))))
-
-(defmacro deref-array-set (obj type i value)
- `(,(accessor-symbol type :set) ,obj ,value (* (the fixnum ,i) ,(foreign-object-size type))))
-
-(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)
- (if (eq type :pointer-self)
- #+cmu `((* (alien:struct ,name)))
- #-cmu `((* ,name))
- `(,(convert-from-uffi-type type :struct))))))
- (if variant
- (push (list def) processed)
- (push def processed))))
- (nreverse processed)))
-
-
-(defmacro def-struct (name &rest fields)
- `(ccl:defrecord ,name ,@(process-struct-fields name fields nil)))
-
-
-(defmacro def-union (name &rest fields)
- `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t))))
-
-
-; Assuming everything is pointer based - no support for Mac handles
-(defmacro get-slot-value (obj type slot) ;use setf to set values
- `(ccl:pref ,obj ,(read-from-string (format nil "~a.~a" type slot))))
-
-
-(defmacro get-slot-pointer (obj type slot)
- `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot)))))
-
-
-
-#| 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)
-
-|#
\ No newline at end of file
+++ /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.3 2002/08/23 19:21:54 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 process-function-args (args)
- (if (null args)
- #+lispworks nil
- #+allegro '(:void)
- #+cmu nil
- #+mcl nil
- (let (processed)
- (dolist (arg args)
- (push (process-one-function-arg arg) processed))
- (nreverse processed))))
-
-(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))
- ))
-
-(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)
- (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))))
-
-
-(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
-;;;; Programmers: Kevin M. Rosenberg and John DeSoi
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: libraries.cl,v 1.3 2002/08/23 19:21:54 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
-(defmacro load-foreign-library (filename &key module supporting-libraries)
- (declare (ignore module supporting-libraries))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (when (ccl:add-to-shared-library-search-path ,filename t)
- (pushnew ,filename *loaded-libraries*))))
-
-;; Copied directly from main source without MCL specializations
-(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)
-
-
-;; Copied directly from main source without MCL specializations
-(defun default-foreign-library-type ()
- "Returns string naming default library type for platform"
- #+(or win32 mswindows) "dll"
- #-(or win32 mswindows) "so")
\ No newline at end of file
+++ /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.3 2002/08/23 19:21:54 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
-;;;
-(defun foreign-object-size (type)
- "Returns the size for the specified mcl type or record type"
- (let ((mcl-type (ccl:find-mactype type nil t)))
- (if mcl-type
- (ccl::mactype-record-size mcl-type)
- (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)) ) ) ) ;error if not a record
-
-
-; trap macros don't work right directly in the macros
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-(defun new-ptr (size)
- (#_NewPtr size))
-
-(defun dispose-ptr (ptr)
- (#_DisposePtr ptr))
-
-)
-
-;;;
-;;; Start of standard 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."
- (if (eq size :unspecified)
- `(new-ptr ,(foreign-object-size (convert-from-uffi-type type :allocation)))
- `(new-ptr ,(* size (foreign-object-size (convert-from-uffi-type type :allocation))))))
-
-
-
-(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))
-
-
-;! need to check uffi update and see if :routine is the right context
-
-(defun accessor-symbol (type get-or-set)
- "Returns the symbol used to access the foreign type."
- (let* ((mcl-type (convert-from-uffi-type (eval type) :routine))
- (mac-type (ccl:find-mactype mcl-type))
- name)
- (ecase get-or-set
- (:get (setf name (ccl::mactype-get-function mac-type)))
- (:set (setf name (ccl::mactype-set-function mac-type))))
- (find-symbol (symbol-name name) :ccl)))
-
-(defmacro deref-pointer (ptr type)
- `(,(accessor-symbol type :get) ,ptr))
-
-
-(defmacro deref-pointer-set (ptr type value)
- `(,(accessor-symbol type :set) ,ptr ,value))
-
-
-(defsetf deref-pointer deref-pointer-set)
-
-
-(defmacro pointer-address (obj)
- `(ccl:%ptr-to-int ,obj))
-
-
-(defmacro with-foreign-objects (bindings &rest body)
- (let ((simple nil) (recs nil) type)
- (dolist (spec (reverse bindings)) ;keep order - macroexpands to let*
- (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate))
- (if (ccl:mactype-p type)
- (push (list (first spec) (foreign-object-size type)) simple)
- (push spec recs)))
- (cond ((and simple recs)
- `(ccl:%stack-block ,simple
- (ccl:rlet ,recs
- ,@body)))
- (simple `(ccl:%stack-block ,simple ,@body))
- (recs `(ccl:rlet ,recs ,@body)))))
-
-
-(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
- #: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
- #:load-foreign-library
-
- ;; Utilities
- ))
+++ /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.3 2002/08/23 19:21:54 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)
-
-; Wrapper for unexported function we have to use
-(defmacro def-mcl-type (name type)
- `(ccl::def-mactype (quote ,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 type)
- `(def-mcl-type ,name (convert-from-uffi-type ,type :type)))
-
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar +type-conversion-hash+ (make-hash-table :size 20)))
-
-
-(defconstant +type-conversion-list+
- '((* . :pointer) (:void . :void)
- (:short . :short)
- (:pointer-void . :pointer)
- (:cstring . :string)
- (:char . :character)
- (:unsigned-char . :unsigned-byte)
- (:byte . :byte)
- (:int . :integer) (:unsigned-int . :unsigned-integer)
- (:long . :long) (:unsigned-long . :unsigned-long)
- (:float . :single-float) (:double . :double-float)
- (:array . :array)))
-
-(dolist (type +type-conversion-list+)
- (setf (gethash (car type) +type-conversion-hash+) (cdr type)))
-
-
-(defmethod ph (&optional (os *standard-output*))
- (maphash #'(lambda (k v) (format os "~&~S => ~S" k v)) +type-conversion-hash+))
-
-(defun convert-from-uffi-type (type context)
- "Converts from a uffi type to an implementation specific type"
- (if (atom type)
- (cond
- #+mcl
- ((and (eq type :void) (eq context :return)) nil)
- (t
- (let ((found-type (gethash type +type-conversion-hash+)))
- (if found-type
- found-type
- type))))
- (cons (convert-from-uffi-type (first type) context)
- (convert-from-uffi-type (rest type) context))))
-
-
-
-
-
-
+++ /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/08/23 19:21:54 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)))
-
-
-#| Works but, supposedly the built in method is better
-(defmacro with-cstring ((foreign-string lisp-string) &body body)
- (let ((result (gensym)))
- `(let* ((,foreign-string (convert-to-cstring ,lisp-string))
- (,result ,@body))
- (dispose-ptr ,foreign-string)
- ,result))
- )
-
-|#
-
-
-
-
-
+++ /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.3 2002/08/23 19:21:54 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.4 2002/08/23 19:21:54 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)))
- (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.3 2002/08/23 19:21:54 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)
-
-
-(def-constant +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)))