From: Kevin M. Rosenberg Date: Mon, 30 Sep 2002 07:56:21 +0000 (+0000) Subject: r2905: *** empty log message *** X-Git-Tag: v1.6.1~288 X-Git-Url: http://git.kpe.io/?p=uffi.git;a=commitdiff_plain;h=130fbcd798fcc0e9513d01519e0837fe7300938b r2905: *** empty log message *** --- diff --git a/debian/changelog b/debian/changelog index a5881c0..86bad87 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,9 +1,15 @@ +cl-uffi (0.9.0-1) unstable; urgency=low + + * Reorganize directories, merge MCL/OpenMCL into main code + + -- Kevin M. Rosenberg Mon, 30 Sep 2002 01:32:03 -0600 + cl-uffi (0.8.6-1) unstable; urgency=low * Fix :pointer-self for OpenMCL. * Multiple changes to support OpenMCL with CLSQL - -- Kevin M. Rosenberg Sun, 29 Sep 2002 14:14:01 -0600 + -- Kevin M. Rosenberg Mon, 30 Sep 2002 01:31:37 -0600 cl-uffi (0.8.5-1) unstable; urgency=low diff --git a/debian/rules b/debian/rules index 6ba6132..1148184 100755 --- a/debian/rules +++ b/debian/rules @@ -46,12 +46,11 @@ install: build dh_testroot dh_clean -k dh_installdirs --all $(clc-systems) $(clc-source) - dh_installdirs -p $(debpkg) $(doc-dir) $(clc-uffi)/src-main $(clc-uffi)/src-mcl + dh_installdirs -p $(debpkg) $(doc-dir) $(clc-uffi)/src # Add here commands to install the package into debian/uffi. dh_install uffi.asd $(clc-uffi) - dh_install "src-main/*.cl" $(clc-uffi)/src-main - dh_install "src-mcl/*.cl" $(clc-uffi)/src-mcl + dh_install "src/*.cl" $(clc-uffi)/src dh_link $(clc-uffi)/uffi.asd $(clc-systems)/uffi.asd rm -rf doc/html diff --git a/doc/html.tar.gz b/doc/html.tar.gz index 128cbdb..17d9946 100644 Binary files a/doc/html.tar.gz and b/doc/html.tar.gz differ diff --git a/src-corman/corman-uffi.cl b/src-corman/corman-uffi.cl deleted file mode 100644 index 5694d60..0000000 --- a/src-corman/corman-uffi.cl +++ /dev/null @@ -1,274 +0,0 @@ -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" -+;;;; 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 - diff --git a/src-main/.cvsignore b/src-main/.cvsignore deleted file mode 100755 index ca8d09f..0000000 --- a/src-main/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -.bin diff --git a/src-main/Makefile b/src-main/Makefile deleted file mode 100644 index 31dc910..0000000 --- a/src-main/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -SUBDIRS := - -include ../Makefile.common - -.PHONY: distclean -distclean: clean diff --git a/src-main/aggregates.cl b/src-main/aggregates.cl deleted file mode 100644 index e4e96f2..0000000 --- a/src-main/aggregates.cl +++ /dev/null @@ -1,123 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: aggregates.cl -;;;; Purpose: UFFI source to handle aggregate types -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: aggregates.cl,v 1.4 2002/09/30 02:45:24 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - -(defmacro def-enum (enum-name args &key (separator-string "#")) - "Creates a constants for a C type enum list, symbols are created -in the created in the current package. The symbol is the concatenation -of the enum-name name, separator-string, and field-name" - (let ((counter 0) - (cmds nil) - (constants nil)) - (declare (fixnum counter)) - (dolist (arg args) - (let ((name (if (listp arg) (car arg) arg)) - (value (if (listp arg) - (prog1 - (setq counter (cadr arg)) - (incf counter)) - (prog1 - counter - (incf counter))))) - (setq name (intern (concatenate 'string - (symbol-name enum-name) - separator-string - (symbol-name name)))) - (push `(uffi:def-constant ,name ,value) constants))) - (setf cmds (append '(progn) - #+allegro `((ff:def-foreign-type ,enum-name :int)) - #+lispworks `((fli:define-c-typedef ,enum-name :int)) - #+cmu `((alien:def-alien-type ,enum-name alien:signed)) - (nreverse constants))) - cmds)) - - -(defmacro def-array-pointer (name-array type) - #+allegro - `(ff:def-foreign-type ,name-array - (:array ,(convert-from-uffi-type type :array))) - #+lispworks - `(fli:define-c-typedef ,name-array - (:c-array ,(convert-from-uffi-type type :array))) - #+cmu - `(alien:def-alien-type ,name-array - (* ,(convert-from-uffi-type type :array))) - ) - -(defun process-struct-fields (name fields) - (let (processed) - (dolist (field fields) - (let ((field-name (car field)) - (type (cadr field))) - (push (append (list field-name) - (if (eq type :pointer-self) - #+cmu `((* (alien:struct ,name))) - #-cmu `((* ,name)) - `(,(convert-from-uffi-type type :struct)))) - processed))) - (nreverse processed))) - - -(defmacro def-struct (name &rest fields) - #+cmu - `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields))) - #+allegro - `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields))) - #+lispworks - `(fli:define-c-struct ,name ,@(process-struct-fields name fields)) - ) - - -(defmacro get-slot-value (obj type slot) - #+(or lispworks cmu) (declare (ignore type)) - #+allegro - `(ff:fslot-value-typed ,type :c ,obj ,slot) - #+lispworks - `(fli:foreign-slot-value ,obj ,slot) - #+cmu - `(alien:slot ,obj ,slot) - ) - -(defmacro get-slot-pointer (obj type slot) - #+(or lispworks cmu) (declare (ignore type)) - #+allegro - `(ff:fslot-value-typed ,type :c ,obj ,slot) - #+lispworks - `(fli:foreign-slot-pointer ,obj ,slot) - #+cmu - `(alien:slot ,obj ,slot) - ) - -(defmacro deref-array (obj type i) - "Returns a field from a row" - #+(or lispworks cmu) (declare (ignore type)) - #+cmu `(alien:deref ,obj ,i) - #+lispworks `(fli:dereference ,obj :index ,i) - #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i) - ) - -(defmacro def-union (name &rest fields) - #+allegro - `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields))) - #+lispworks - `(fli:define-c-union ,name ,@(process-struct-fields name fields)) - #+cmu - `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields))) -) diff --git a/src-main/functions.cl b/src-main/functions.cl deleted file mode 100644 index a535876..0000000 --- a/src-main/functions.cl +++ /dev/null @@ -1,83 +0,0 @@ -;;;; -*- 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)))) - - diff --git a/src-main/libraries.cl b/src-main/libraries.cl deleted file mode 100644 index 0cf1e0c..0000000 --- a/src-main/libraries.cl +++ /dev/null @@ -1,108 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: libraries.cl -;;;; Purpose: UFFI source to load foreign libraries -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: libraries.cl,v 1.3 2002/09/30 01:57:32 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - -(defvar *loaded-libraries* nil - "List of foreign libraries loaded. Used to prevent reloading a library") - -(defun default-foreign-library-type () - "Returns string naming default library type for platform" - #+(or win32 mswindows) "dll" - #-(or win32 mswindows macosx) "so" - #+macosx "dylib") - -(defun find-foreign-library (names directories &key types drive-letters) - "Looks for a foreign library. directories can be a single -string or a list of strings of candidate directories. Use default -library type if type is not specified." - (unless types - (setq types (default-foreign-library-type))) - (unless (listp types) - (setq types (list types))) - (unless (listp names) - (setq names (list names))) - (unless (listp directories) - (setq directories (list directories))) - #+(or win32 mswindows) - (unless (listp drive-letters) - (setq drive-letters (list drive-letters))) - #-(or win32 mswindows) - (setq drive-letters '(nil)) - (dolist (drive-letter drive-letters) - (dolist (name names) - (dolist (dir directories) - (dolist (type types) - (let ((path (make-pathname - #+lispworks :host - #+lispworks (when drive-letter drive-letter) - #-lispworks :device - #-lispworks (when drive-letter drive-letter) - :name name - :type type - :directory - (etypecase dir - (pathname - (pathname-directory dir)) - (list - dir) - (string - (pathname-directory - (parse-namestring dir))))))) - (when (probe-file path) - (return-from find-foreign-library path))))))) - nil) - - -(defun load-foreign-library (filename &key module supporting-libraries - force-load) - #+allegro (declare (ignore module supporting-libraries)) - #+lispworks (declare (ignore supporting-libraries)) - #+cmu (declare (ignore module)) - - (when (and filename (probe-file filename)) - (if (pathnamep filename) ;; ensure filename is a string to check if - (setq filename (namestring filename))) ; already loaded - - (if (and (not force-load) - (find filename *loaded-libraries* :test #'string-equal)) - t ;; return T, but don't reload library - (progn - #+cmu - (let ((type (pathname-type (parse-namestring filename)))) - (if (equal type "so") - (sys::load-object-file filename) - (alien:load-foreign filename - :libraries - (convert-supporting-libraries-to-string - supporting-libraries)))) - #+lispworks (fli:register-module module :real-name filename) - #+allegro (load filename) - #+openmcl (ccl:open-shared-library filename) - #+(and mcl (not openmcl)) (ccl:add-to-shared-library-search-path filename t) - - (push filename *loaded-libraries*) - t))) - ) - -(defun convert-supporting-libraries-to-string (libs) - (let (lib-load-list) - (dolist (lib libs) - (push (format nil "-l~A" lib) lib-load-list)) - (nreverse lib-load-list))) diff --git a/src-main/objects.cl b/src-main/objects.cl deleted file mode 100644 index d9af1dc..0000000 --- a/src-main/objects.cl +++ /dev/null @@ -1,144 +0,0 @@ -;;;; -*- 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))) - - - diff --git a/src-main/package.cl b/src-main/package.cl deleted file mode 100644 index abacbc8..0000000 --- a/src-main/package.cl +++ /dev/null @@ -1,72 +0,0 @@ -;;;; -*- 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 - )) diff --git a/src-main/primitives.cl b/src-main/primitives.cl deleted file mode 100644 index 08ef00b..0000000 --- a/src-main/primitives.cl +++ /dev/null @@ -1,206 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: primitives.cl -;;;; Purpose: UFFI source to handle immediate types -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: primitives.cl,v 1.3 2002/09/30 02:45:24 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - -(defmacro def-constant (name value &key (export nil)) - "Macro to define a constant and to export it" - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant ,name ,value) - ,(when export (list 'export `(quote ,name))) - ',name)) - -(defmacro def-type (name type) - "Generates a (deftype) statement for CL. Currently, only CMUCL -supports takes advantage of this optimization." - #+(or lispworks allegro) - (declare (ignore type)) - #+(or lispworks allegro) - `(deftype ,name () t) - #+cmu - `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare))) - #+sbcl - `(deftype ,name () '(sb-alien:alien ,(convert-from-uffi-type type :declare))) - ) - -(defmacro null-char-p (val) - "Returns T if character is NULL" - `(zerop ,val)) - -(defmacro def-foreign-type (name type) - #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type)) - #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type)) - #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type)) - #+sbcl `(sb-alien:def-alien-type ,name ,(convert-from-uffi-type type :type)) - ) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar +type-conversion-hash+ (make-hash-table :size 20)) - #+(or cmu sbcl) (defvar +cmu-def-type-hash+ (make-hash-table :size 20)) - ) - -#+cmu -(defconstant +cmu-def-type-list+ - '((:char . (alien:signed 8)) - (:unsigned-char . (alien:unsigned 8)) - (:byte . (alien:signed 8)) - (:unsigned-byte . (alien:unsigned 8)) - (:short . (alien:signed 16)) - (:unsigned-short . (alien:unsigned 16)) - (:int . (alien:signed 32)) - (:unsigned-int . (alien:unsigned 32)) - (:long . (alien:signed 32)) - (:unsigned-long . (alien:unsigned 32)) - (:float . alien:single-float) - (:double . alien:double-float) - ) - "Conversions in CMUCL for def-foreign-type are different than in def-function") -#+sbcl -(defconstant +cmu-def-type-list+ - '((:char . (sb-alien:signed 8)) - (:unsigned-char . (sb-alien:unsigned 8)) - (:byte . (sb-alien:signed 8)) - (:unsigned-byte . (sb-alien:unsigned 8)) - (:short . (sb-alien:signed 16)) - (:unsigned-short . (sb-alien:unsigned 16)) - (:int . (sb-alien:signed 32)) - (:unsigned-int . (sb-alien:unsigned 32)) - (:long . (sb-alien:signed 32)) - (:unsigned-long . (sb-alien:unsigned 32)) - (:float . sb-alien:single-float) - (:double . sb-alien:double-float) - ) - "Conversions in SBCL for def-foreign-type are different than in def-function") - -(defparameter +type-conversion-list+ nil) - -#+cmu -(setq +type-conversion-list+ - '((* . *) (:void . c-call:void) - (:short . c-call:short) - (:pointer-void . (* t)) - (:cstring . c-call:c-string) - (:char . c-call:char) - (:unsigned-char . (alien:unsigned 8)) - (:byte . (alien:signed 8)) - (:unsigned-byte . (alien:unsigned 8)) - (:short . c-call:unsigned-short) - (:unsigned-short . c-call:unsigned-short) - (:int . alien:integer) (:unsigned-int . c-call:unsigned-int) - (:long . c-call:long) (:unsigned-long . c-call:unsigned-long) - (:float . c-call:float) (:double . c-call:double) - (:array . alien:array))) - -#+sbcl -(setq +type-conversion-list+ - '((* . *) (:void . void) - (:short . short) - (:pointer-void . (* t)) - (:cstring . c-string) - (:char . char) - (:unsigned-char . (sb-alien:unsigned 8)) - (:byte . (sb-alien:signed 8)) - (:unsigned-byte . (sb-alien:unsigned 8)) - (:short . unsigned-short) - (:unsigned-short . unsigned-short) - (:int . integer) (:unsigned-int . unsigned-int) - (:long . long) (:unsigned-long . unsigned-long) - (:float . float) (:double . double) - (:array . array))) - -#+allegro -(setq +type-conversion-list+ - '((* . *) (:void . :void) - (:short . :short) - (:pointer-void . (* :void)) - (:cstring . (* :unsigned-char)) - (:byte . :char) - (:unsigned-byte . :unsigned-byte) - (:char . :char) - (:unsigned-char . :unsigned-char) - (:int . :int) (:unsigned-int . :unsigned-int) - (:long . :long) (:unsigned-long . :unsigned-long) - (:float . :float) (:double . :double) - (:array . :array))) -#+lispworks -(setq +type-conversion-list+ - '((* . :pointer) (:void . :void) - (:short . :short) - (:pointer-void . (:pointer :void)) - (:cstring . (:reference-pass (:ef-mb-string :external-format :latin-1) - :allow-null t)) - (:cstring-returning . (:reference (:ef-mb-string :external-format :latin-1) :allow-null t)) - (:byte . :byte) - (:unsigned-byte . (:unsigned :byte)) - (:char . :char) - (:unsigned-char . (:unsigned :char)) - (:int . :int) (:unsigned-int . (:unsigned :int)) - (:long . :long) (:unsigned-long . (:unsigned :long)) - (:float . :float) (:double . :double) - (:array . :c-array))) - -(dolist (type +type-conversion-list+) - (setf (gethash (car type) +type-conversion-hash+) (cdr type))) - -#+(or cmu sbcl) -(dolist (type +cmu-def-type-list+) - (setf (gethash (car type) +cmu-def-type-hash+) (cdr type))) - -(defun basic-convert-from-uffi-type (type) - (let ((found-type (gethash type +type-conversion-hash+))) - (if found-type - found-type - type))) - -(defun convert-from-uffi-type (type context) - "Converts from a uffi type to an implementation specific type" - (if (atom type) - (cond - #+allegro - ((and (or (eq context :routine) (eq context :return)) - (eq type :cstring)) - (setq type '((* :char) integer))) - #+(or cmu sbcl) - ((eq context :type) - (let ((cmu-type (gethash type +cmu-def-type-hash+))) - (if cmu-type - cmu-type - (basic-convert-from-uffi-type type)))) - #+lispworks - ((and (eq context :return) - (eq type :cstring)) - (basic-convert-from-uffi-type :cstring-returning)) - (t - (basic-convert-from-uffi-type type))) - (let ((sub-type (car type))) - (case sub-type - (cl:quote - (convert-from-uffi-type (cadr type) context)) - (:struct-pointer - #+openmcl `(:* (:struct ,(convert-from-uffi-type (cadr type) :struct))) - #-openmcl (convert-from-uffi-type (list '* (cadr type)) :struct) - ) - (:struct - #+openmcl `(:struct ,(convert-from-uffi-type (cadr type) :struct)) - #-openmcl (convert-from-uffi-type (cadr type) :struct) - ) - (t - (cons (convert-from-uffi-type (first type) context) - (convert-from-uffi-type (rest type) context))))))) - diff --git a/src-main/strings.cl b/src-main/strings.cl deleted file mode 100644 index 3061644..0000000 --- a/src-main/strings.cl +++ /dev/null @@ -1,193 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: strings.cl -;;;; Purpose: UFFI source to handle strings, cstring and foreigns -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: strings.cl,v 1.2 2002/09/19 03:33:25 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - - -(defvar +null-cstring-pointer+ - #+cmu nil - #+allegro 0 - #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char)) - #-(or cmu allegro lispworks) nil -) - -(defmacro convert-from-cstring (obj) - "Converts a string from a c-call. Same as convert-from-foreign-string, except -that LW/CMU automatically converts strings from c-calls." - #+cmu obj - #+lispworks obj - #+allegro - (let ((stored (gensym))) - `(let ((,stored ,obj)) - (if (zerop ,stored) - nil - (values (excl:native-to-string ,stored))))) - ) - -(defmacro convert-to-cstring (obj) - #+cmu obj - #+lispworks obj - #+allegro - `(if (null ,obj) - 0 - (values (excl:string-to-native ,obj))) - ) - -(defmacro free-cstring (obj) - #+cmu (declare (ignore obj)) - #+lispworks (declare (ignore obj)) - #+allegro - `(unless (zerop obj) - (ff:free-fobject ,obj)) - ) - -(defmacro with-cstring ((cstring lisp-string) &body body) - #+cmu - `(let ((,cstring ,lisp-string)) ,@body) - #+lispworks - `(let ((,cstring ,lisp-string)) ,@body) - #+allegro - (let ((acl-native (gensym))) - `(excl:with-native-string (,acl-native ,lisp-string) - (let ((,cstring (if ,lisp-string ,acl-native 0))) - ,@body))) - ) - -(defmacro with-cstrings (bindings &rest body) - (if bindings - `(with-cstring ,(car bindings) - (with-cstrings ,(cdr bindings) - ,@body)) - `(progn ,@body))) - -;;; Foreign string functions - -(defmacro convert-to-foreign-string (obj) - #+lispworks - `(if (null ,obj) - +null-cstring-pointer+ - (fli:convert-to-foreign-string ,obj)) - #+allegro - `(if (null ,obj) - 0 - (values (excl:string-to-native ,obj))) - #+cmu - (let ((size (gensym)) - (storage (gensym)) - (i (gensym))) - `(etypecase ,obj - (null - (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8)))) - (string - (let* ((,size (length ,obj)) - (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size)))) - (setq ,storage (alien:cast ,storage (* (alien:unsigned 8)))) - (locally - (declare (optimize (speed 3) (safety 0))) - (dotimes (,i ,size) - (declare (fixnum ,i)) - (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i)))) - (setf (alien:deref ,storage ,size) 0)) - ,storage)))) - ) - - -;; Either length or null-terminated-p must be non-nil -(defmacro convert-from-foreign-string (obj &key - length - (null-terminated-p t)) - #+allegro - `(if (zerop ,obj) - nil - (values (excl:native-to-string - ,obj - ,@(if length (list :length length) (values)) - :truncate (not ,null-terminated-p)))) - #+lispworks - `(if (fli:null-pointer-p ,obj) - nil - (fli:convert-from-foreign-string - ,obj - ,@(if length (list :length length) (values)) - :null-terminated-p ,null-terminated-p - :external-format '(:latin-1 :eol-style :lf))) - #+cmu - `(if (null-pointer-p ,obj) - nil - (cmucl-naturalize-cstring (alien:alien-sap ,obj) - :length ,length - :null-terminated-p ,null-terminated-p)) - ) - - - -(defmacro allocate-foreign-string (size &key (unsigned t)) - #+cmu - (let ((array-def (gensym))) - `(let ((,array-def (list 'alien:array 'c-call:char ,size))) - (eval `(alien:cast (alien:make-alien ,,array-def) - ,(if ,unsigned - '(* (alien:unsigned 8)) - '(* (alien:signed 8))))))) - #+lispworks - `(fli:allocate-foreign-object :type - ,(if unsigned - ''(:unsigned :char) - :char) - :nelems ,size) - #+allegro - (declare (ignore unsigned)) - #+allegro - `(ff:allocate-fobject :char :c ,size) - ) - -(defmacro with-foreign-string ((foreign-string lisp-string) &body body) - (let ((result (gensym))) - `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string)) - (,result (progn ,@body))) - (declare (dynamic-extent ,foreign-string)) - (free-foreign-object ,foreign-string) - ,result))) - - -;; Modified from CMUCL's source to handle non-null terminated strings -#+cmu -(defun cmucl-naturalize-cstring (sap &key - length - (null-terminated-p t)) - (declare (type system:system-area-pointer sap)) - (locally - (declare (optimize (speed 3) (safety 0))) - (let ((null-terminated-length - (when null-terminated-p - (loop - for offset of-type fixnum upfrom 0 - until (zerop (system:sap-ref-8 sap offset)) - finally (return offset))))) - (if length - (if (and null-terminated-length - (> (the fixnum length) (the fixnum null-terminated-length))) - (setq length null-terminated-length)) - (setq length null-terminated-length))) - (let ((result (make-string length))) - (kernel:copy-from-system-area sap 0 - result (* vm:vector-data-offset - vm:word-bits) - (* length vm:byte-bits)) - result))) diff --git a/src-mcl/Makefile b/src-mcl/Makefile deleted file mode 100644 index 31dc910..0000000 --- a/src-mcl/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -SUBDIRS := - -include ../Makefile.common - -.PHONY: distclean -distclean: clean diff --git a/src-mcl/aggregates.cl b/src-mcl/aggregates.cl deleted file mode 100644 index 428013c..0000000 --- a/src-mcl/aggregates.cl +++ /dev/null @@ -1,176 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: aggregates.cl -;;;; Purpose: UFFI source to handle aggregate types -;;;; Programmers: Kevin M. Rosenberg and John DeSoi -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: aggregates.cl,v 1.3 2002/09/30 01:57:32 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and John DeSoi -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - - - -(defmacro def-enum (enum-name args &key (separator-string "#")) - "Creates a constants for a C type enum list, symbols are created -in the created in the current package. The symbol is the concatenation -of the enum-name name, separator-string, and field-name" - (let ((counter 0) - (cmds nil) - (constants nil)) - (declare (fixnum counter)) - (dolist (arg args) - (let ((name (if (listp arg) (car arg) arg)) - (value (if (listp arg) - (prog1 - (setq counter (cadr arg)) - (incf counter)) - (prog1 - counter - (incf counter))))) - (setq name (intern (concatenate 'string - (symbol-name enum-name) - separator-string - (symbol-name name)))) - (push `(uffi:def-constant ,name ,value) constants))) - (setf cmds (append '(progn) - #+allegro `((ff:def-foreign-type ,enum-name :int)) - #+lispworks `((fli:define-c-typedef ,enum-name :int)) - #+cmu `((alien:def-alien-type ,enum-name alien:signed)) - #-openmcl `((def-mcl-type ,enum-name :integer)) - #+openmcl `((ccl::def-foreign-type ,enum-name :int)) - (nreverse constants))) - cmds)) - - - -(defmacro def-array-pointer (name-array type) - #-openmcl - `(def-mcl-type ,name-array '(:array ,type)) - #+openmcl - `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))) - - - -; so we could allow '(:array :long) or deref with other type like :long only -(defun array-type (type) - (let ((result type)) - (when (listp type) - (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type))) - (when (and (listp type-list) (eq (car type-list) :array)) - (setf result (cadr type-list))))) - result)) - - -(defmacro deref-array (obj type i) - "Returns a field from a row" - (let* ((array-type (array-type type)) - (local-type (convert-from-uffi-type array-type :allocation)) - (accessor (first (macroexpand `(ccl:pref obj ,local-type))))) - `(,accessor - ,obj - (* (the fixnum ,i) ,(size-of-foreign-type local-type))))) - - -; this expands to the %set-xx functions which has different params than %put-xx -(defmacro deref-array-set (obj type i value) - (let* ((array-type (array-type type)) - (local-type (convert-from-uffi-type array-type :allocation)) - (accessor (first (macroexpand `(ccl:pref obj ,local-type)))) - (settor (first (macroexpand `(setf (,accessor obj ,local-type) value))))) - `(,settor - ,obj - (* (the fixnum ,i) ,(size-of-foreign-type local-type)) - ,value))) - -(defsetf deref-array deref-array-set) - - -(defun process-struct-fields (name fields variant) - (let (processed) - (dolist (field fields) - (let* ((field-name (car field)) - (type (cadr field)) - (def (append (list field-name) - (cond - ((eq type :pointer-self) - #+cmu `((* (alien:struct ,name))) - #+openmcl `((:* (:struct ,name))) - #-(or cmu openmcl) `((* ,name)) - ) - (t - `(,(convert-from-uffi-type type :struct))))))) - (if variant - (push (list def) processed) - (push def processed)))) - (nreverse processed))) - -#-openmcl -(defmacro def-struct (name &rest fields) - `(ccl:defrecord ,name ,@(process-struct-fields name fields nil))) - -#-openmcl -(defmacro def-union (name &rest fields) - `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))) - - -#+openmcl -(defmacro def-struct (name &rest fields) - `(ccl::def-foreign-type nil - (:struct ,name ,@(process-struct-fields name fields nil)))) - -#+openmcl -(defmacro def-union (name &rest fields) - `(ccl::def-foreign-type nil - (:union ,name ,@(process-struct-fields name fields nil)))) - -; Assuming everything is pointer based - no support for Mac handles -(defmacro get-slot-value (obj type slot) ;use setf to set values - `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))) - -(defmacro set-slot-value (obj type slot value) ;use setf to set values - `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value)) - - -(defsetf get-slot-value set-slot-value) - - -#-openmcl -(defmacro get-slot-pointer (obj type slot) - `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))) - -#+openmcl -(defmacro get-slot-pointer (obj type slot) - `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot))) - (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field)))))) - - - -#| a few simple tests -(def-union union - (l1 :long) - (s1 :short)) - -(def-struct struct - (s1 :short) - (l1 :long) - (u1 :union)) - -(defvar s (allocate-foreign-object :struct)) -(setf (get-slot-value s :struct :s1) 3) -(get-slot-value s :struct :s1) -(setf (get-slot-value s :struct :u1.s1) 5) -(get-slot-value s :struct :u1.s1) - -|# diff --git a/src-mcl/functions.cl b/src-mcl/functions.cl deleted file mode 100644 index 693f15d..0000000 --- a/src-mcl/functions.cl +++ /dev/null @@ -1,93 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: function.cl -;;;; Purpose: UFFI source to C function defintions -;;;; Programmers: Kevin M. Rosenberg and John DeSoi -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: functions.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and John DeSoi -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - - -(defun make-lisp-name (name) - (let ((converted (substitute #\- #\_ name))) - (intern - #+case-sensitive converted - #-case-sensitive (string-upcase converted)))) - -#-openmcl -(defun process-function-args (args) - (if (null args) - nil - (let (processed) - (dolist (arg args) - (push (process-one-function-arg arg) processed)) - (nreverse processed)))) - -#-openmcl -(defun process-one-function-arg (arg) - (let ((name (car arg)) - (type (convert-from-uffi-type (cadr arg) :routine))) - (if (and (listp type) (listp (car type))) - (append (list name) type) - (list name type)) - )) - - -;; name is either a string representing foreign name, or a list -;; of foreign-name as a string and lisp name as a symbol -#-openmcl -(defmacro def-function (names args &key module returning) - (declare (ignore module)) - (let* ((result-type (convert-from-uffi-type returning :return)) - (function-args (process-function-args args)) - (foreign-name (if (atom names) names (car names))) - (lisp-name (if (atom names) (make-lisp-name names) (cadr names)))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (ccl:define-entry-point (,lisp-name ,foreign-name) - ,function-args - ,result-type)))) - - - -#+openmcl -(defun process-function-args (args) - (if (null args) - (values nil nil) - (let ((processed nil) - (params nil) - name type) - (dolist (arg args) - (setf name (car arg)) - (setf type (convert-from-uffi-type (cadr arg) :routine)) - ;(when (and (listp type) (eq (car type) :address)) - ;(setf type :address)) - (push name params) - (push type processed) - (push name processed)) - (values (nreverse params) (nreverse processed))))) - - -#+openmcl -(defmacro def-function (names args &key module returning) - (declare (ignore module)) - (let* ((result-type (convert-from-uffi-type returning :return)) - (foreign-name (if (atom names) names (car names))) - (lisp-name (if (atom names) (make-lisp-name names) (cadr names)))) - #+darwinppc-target - (setf foreign-name (concatenate 'string "_" foreign-name)) - (multiple-value-bind (params args) (process-function-args args) - `(defun ,lisp-name ,params - (ccl::external-call ,foreign-name ,@args ,result-type))))) diff --git a/src-mcl/libraries.cl b/src-mcl/libraries.cl deleted file mode 100644 index 3226552..0000000 --- a/src-mcl/libraries.cl +++ /dev/null @@ -1,102 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: libraries.cl -;;;; Purpose: UFFI source to load foreign libraries -;;;; Programmers: Kevin M. Rosenberg and John DeSoi -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: libraries.cl,v 1.4 2002/09/30 01:57:32 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and John DeSoi -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - -(defvar *loaded-libraries* nil - "List of foreign libraries loaded. Used to prevent reloading a library") - -;in MCL calling this more than once for the same library does not do anything -#-openmcl -(defun load-foreign-library (filename &key module supporting-libraries force-load) - (declare (ignore module supporting-libraries force-load)) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (when (ccl:add-to-shared-library-search-path filename t) - (pushnew filename *loaded-libraries*)))) - - -; Note we are not dealing with OpenMCL's ability to close the library -; As of v0.13 .dylibs can't be closed but bundles can. See the docs for the latest. -#+openmcl -(defun load-foreign-library (filename &key module supporting-libraries force-load) - (declare (ignore module supporting-libraries force-load)) - (let ((path (if (pathnamep filename) (namestring filename) filename))) - (when (stringp path) - (if (position path *loaded-libraries* :test #'string-equal) - t - (when (ccl:open-shared-library path) - (pushnew path *loaded-libraries*) - t))))) - - -(defun find-foreign-library (names directories &key types drive-letters) - "Looks for a foreign library. directories can be a single -string or a list of strings of candidate directories. Use default -library type if type is not specified." - (unless types - (setq types (default-foreign-library-type))) - (unless (listp types) - (setq types (list types))) - (unless (listp names) - (setq names (list names))) - (unless (listp directories) - (setq directories (list directories))) - #+(or win32 mswindows) - (unless (listp drive-letters) - (setq drive-letters (list drive-letters))) - #-(or win32 mswindows) - (setq drive-letters '(nil)) - (dolist (drive-letter drive-letters) - (dolist (name names) - (dolist (dir directories) - (dolist (type types) - (let ((path (make-pathname - #+lispworks :host - #+lispworks (when drive-letter drive-letter) - #-lispworks :device - #-lispworks (when drive-letter drive-letter) - :name name - :type type - :directory - (etypecase dir - (pathname - (pathname-directory dir)) - (list - dir) - (string - (pathname-directory - (parse-namestring dir))))))) - (when (probe-file path) - (return-from find-foreign-library path))))))) - nil) - - - -(defun default-foreign-library-type () - "Returns string naming default library type for platform" - #+(or win32 mswindows) "dll" - #-(or win32 mswindows mcl) "so" - #+openmcl '("dylib" "so" nil) - #-openmcl '(nil)) - - - - - diff --git a/src-mcl/objects.cl b/src-mcl/objects.cl deleted file mode 100644 index 82adf16..0000000 --- a/src-mcl/objects.cl +++ /dev/null @@ -1,130 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: objects.cl -;;;; Purpose: UFFI source to handle objects and pointers -;;;; Programmers: Kevin M. Rosenberg and John DeSoi -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: objects.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and John DeSoi -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - - -;;; -;;; Some MCL specific utilities -;;; - -; trap macros don't work right directly in the macros -(eval-when (:compile-toplevel :load-toplevel :execute) - -#-openmcl -(defun new-ptr (size) - (#_NewPtr size)) - -#-openmcl -(defun dispose-ptr (ptr) - (#_DisposePtr ptr)) - -#+openmcl -(defmacro new-ptr (size) - `(ccl::malloc ,size)) - -#+openmcl -(defmacro dispose-ptr (ptr) - `(ccl::free ,ptr)) - -) - -;;; -;;; Start of standard UFFI -;;; -(defun size-of-foreign-type (type) - "Returns the size for the specified mcl type or record type" - #+openmcl - (ccl::%foreign-type-or-record-size type :bytes) - #-openmcl - (let ((mcl-type (ccl:find-mactype type nil t))) - (if mcl-type - (ccl::mactype-record-size mcl-type) - (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)) ) ) ) ;error if not a record - - - -(defmacro allocate-foreign-object (type &optional (size :unspecified)) - "Allocates an instance of TYPE. If size is specified, then allocate -an array of TYPE with size SIZE." - (if (eq size :unspecified) - `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation))) - `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))))) - - - -(defmacro free-foreign-object (obj) - `(dispose-ptr ,obj)) - -(defmacro null-pointer-p (obj) - `(ccl:%null-ptr-p ,obj)) - - -(defmacro make-null-pointer (type) - (declare (ignore type)) - `(ccl:%null-ptr)) - - -;already a macptr -(defmacro char-array-to-pointer (obj) - obj) - - -(defmacro deref-pointer (ptr type) - `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref))) - -(defmacro deref-pointer-set (ptr type value) - `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value)) - -(defsetf deref-pointer deref-pointer-set) - - -(defmacro ensure-char-character (obj) - #-openmcl obj - #+openmcl `(code-char ,obj)) - - -(defmacro ensure-char-integer (obj) - #-openmcl `(char-code ,obj) - #+openmcl obj) - - -(defmacro pointer-address (obj) - `(ccl:%ptr-to-int ,obj)) - - - -(defmacro with-foreign-objects (bindings &rest body) - (let ((params nil) type count) - (dolist (spec (reverse bindings)) ;keep order - macroexpands to let* - (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate)) - (setf count 1) - (when (and (listp type) (eq (first type) :array)) - (setf count (nth 2 type)) - (unless (integerp count) (error "Invalid size for array: ~a" type)) - (setf type (nth 1 type))) - (push (list (first spec) (* count (size-of-foreign-type type))) params)) - `(ccl:%stack-block ,params ,@body))) - - -(defmacro with-foreign-object ((var type) &rest body) - `(with-foreign-objects ((,var ,type)) - ,@body)) - diff --git a/src-mcl/package.cl b/src-mcl/package.cl deleted file mode 100644 index 02849bc..0000000 --- a/src-mcl/package.cl +++ /dev/null @@ -1,72 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: package.cl -;;;; Purpose: Defines UFFI package -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :cl-user) - -(defpackage :uffi - (:use :cl) - (:export - - ;; immediate types - #:def-constant - #:def-foreign-type - #:def-type - #:null-char-p - - ;; aggregate types - #:def-enum - #:def-struct - #:get-slot-value - #:get-slot-pointer - #:def-array-pointer - #:deref-array - #:def-union - - ;; objects - #:allocate-foreign-object - #:free-foreign-object - #:with-foreign-object - #:with-foreign-objects - #:size-of-foreign-type - #:pointer-address - #:deref-pointer - #:ensure-char-character - #:ensure-char-integer - #:null-pointer-p - #:make-null-pointer - #:+null-cstring-pointer+ - #:char-array-to-pointer - - ;; string functions - #:convert-from-cstring - #:convert-to-cstring - #:free-cstring - #:with-cstring - #:with-cstrings - #:convert-from-foreign-string - #:convert-to-foreign-string - #:allocate-foreign-string - #:with-foreign-string - - ;; function call - #:def-function - - ;; Libraries - #:find-foreign-library - #:load-foreign-library - #:default-foreign-library-type - )) diff --git a/src-mcl/primitives.cl b/src-mcl/primitives.cl deleted file mode 100644 index 6cbe03e..0000000 --- a/src-mcl/primitives.cl +++ /dev/null @@ -1,157 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: primitives.cl -;;;; Purpose: UFFI source to handle immediate types -;;;; Programmers: Kevin M. Rosenberg and John DeSoi -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: primitives.cl,v 1.4 2002/09/30 01:57:32 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and John DeSoi -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - - -(defvar *keyword-package* (find-package "KEYWORD")) - -; MCL and OpenMCL expect a lot of FFI elements to be keywords (e.g. struct field names in OpenMCL) -; So this provides a function to convert any quoted symbols to keywords. -(defun keyword (obj) - (cond ((keywordp obj) - obj) - ((null obj) - nil) - ((symbolp obj) - (intern (symbol-name obj) *keyword-package*)) - ((and (listp obj) (eq (car obj) 'cl:quote)) - (keyword (cadr obj))) - ((stringp obj) - (intern obj *keyword-package*)) - (t - obj))) - - -; Wrapper for unexported function we have to use -#-openmcl -(defmacro def-mcl-type (name type) - `(ccl::def-mactype ,(keyword name) (ccl:find-mactype ,type))) - - -(defmacro def-constant (name value &key (export nil)) - "Macro to define a constant and to export it" - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant ,name ,value) - ,(if export (list 'export `(quote ,name)) (values)))) - -(defmacro def-type (name type) - "Generates a (deftype) statement for CL. Currently, only CMUCL -supports takes advantage of this optimization." - (declare (ignore type)) - `(deftype ,name () t)) - -(defmacro null-char-p (val) - "Returns T if character is NULL" - `(zerop ,val)) - - -(defmacro def-foreign-type (name uffi-type) - (let ((type (convert-from-uffi-type uffi-type :type))) - (unless (or (keywordp type) (consp type)) - (setf type `(quote ,type))) - #-openmcl - `(def-mcl-type ,(keyword name) ,type) - #+openmcl - `(ccl::def-foreign-type ,(keyword name) ,type))) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar +type-conversion-hash+ (make-hash-table :size 20))) - -#-openmcl -(defconstant +type-conversion-list+ - '((* . :pointer) (:void . :void) - (:short . :short) (:unsigned-short . :unsigned-short) - (:pointer-void . :pointer) - (:cstring . :string) - (:char . :character) - (:unsigned-char . :unsigned-byte) - (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte) - (:int . :long) (:unsigned-int . :unsigned-long) - (:long . :long) (:unsigned-long . :unsigned-long) - (:float . :single-float) (:double . :double-float) - (:array . :array))) - -#+openmcl -(defconstant +type-conversion-list+ - '((* . :address) (:void . :void) - (:short . :short) (:unsigned-short . :unsigned-short) - (:pointer-void . :address) - (:cstring . :address) - (:char . :signed-char) - (:unsigned-char . :unsigned-char) - (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte) - (:int . :int) (:unsigned-int . :unsigned-int) - (:long . :long) (:unsigned-long . :unsigned-long) - (:long-long . :signed-doubleword) (:unsigned-long-long . :unsigned-doubleword) - (:float . :single-float) (:double . :double-float) - (:array . :array))) - - -(dolist (type +type-conversion-list+) - (setf (gethash (car type) +type-conversion-hash+) (cdr type))) - - -(defmethod ph (&optional (os *standard-output*)) - (maphash #'(lambda (k v) (format os "~&~S => ~S" k v)) +type-conversion-hash+)) - - - -(defun basic-convert-from-uffi-type (type) - (let ((found-type (gethash type +type-conversion-hash+))) - (if found-type - found-type - (keyword type)))) - -(defun %convert-from-uffi-type (type context) - "Converts from a uffi type to an implementation specific type" - (if (atom type) - (cond - #-openmcl ((and (eq type :void) (eq context :return)) nil) - (t (basic-convert-from-uffi-type type))) - (let ((sub-type (car type))) - (case sub-type - (cl:quote - (%convert-from-uffi-type (cadr type) context)) - (:struct-pointer - #+openmcl `(:* (:struct ,(convert-from-uffi-type (cadr type) :struct))) - #-openmcl `(,(convert-from-uffi-type (list '* (cadr type)) :struct)) - ) - (:struct - #+openmcl `(:struct ,(convert-from-uffi-type (cadr type) :struct)) - #-openmcl `(,(convert-from-uffi-type (cadr type) :struct)) - ) - (t - (cons (%convert-from-uffi-type (first type) context) - (%convert-from-uffi-type (rest type) context))))))) - -(defun convert-from-uffi-type (type context) - (let ((result (%convert-from-uffi-type type context))) - (cond - ((atom result) result) - #+openmcl - ((eq (car result) :address) - (if (eq context :struct) - (append '(:*) (cdr result)) - :address)) - #-openmcl - ((and (eq (car result) :pointer) (eq context :allocation) :pointer)) - (t result)))) diff --git a/src-mcl/strings.cl b/src-mcl/strings.cl deleted file mode 100644 index 0c9a1c6..0000000 --- a/src-mcl/strings.cl +++ /dev/null @@ -1,202 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: strings.cl -;;;; Purpose: UFFI source to handle strings, cstring and foreigns -;;;; Programmers: Kevin M. Rosenberg and John DeSoi -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: strings.cl,v 1.3 2002/09/29 18:54:17 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and John DeSoi -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - - -(defvar +null-cstring-pointer+ (ccl:%null-ptr)) - -(defmacro convert-from-cstring (obj) - "Converts a string from a c-call. Same as convert-from-foreign-string, except -that CMU automatically converts strings from c-calls." - #+cmu obj - #+lispworks - (let ((stored (gensym))) - `(let ((,stored ,obj)) - (if (fli:null-pointer-p ,stored) - nil - (fli:convert-from-foreign-string ,stored)))) - #+allegro - (let ((stored (gensym))) - `(let ((,stored ,obj)) - (if (zerop ,stored) - nil - (values (excl:native-to-string ,stored))))) - #+mcl - (let ((stored (gensym))) - `(let ((,stored ,obj)) - (if (ccl:%null-ptr-p ,stored) - nil - (values (ccl:%get-cstring ,stored))))) - - - ) - -(defmacro convert-to-cstring (obj) - #+lispworks - `(if (null ,obj) - +null-cstring-pointer+ - (fli:convert-to-foreign-string ,obj)) - #+allegro - `(if (null ,obj) - 0 - (values (excl:string-to-native ,obj))) - #+cmu - (declare (ignore obj)) - #+mcl - `(if (null ,obj) - +null-cstring-pointer+ - (let ((ptr (new-ptr (1+ (length ,obj))))) - (ccl:%put-cstring ptr ,obj) - ptr)) - ) - -(defmacro free-cstring (obj) - #+lispworks - `(unless (fli:null-pointer-p ,obj) - (fli:free-foreign-object ,obj)) - #+allegro - `(unless (zerop obj) - (ff:free-fobject ,obj)) - #+cmu - (declare (ignore obj)) - #+mcl - `(unless (ccl:%null-ptr-p ,obj) - (dispose-ptr ,obj)) - - ) - -;; Either length or null-terminated-p must be non-nil -(defmacro convert-from-foreign-string (obj &key - length - (null-terminated-p t)) - #+allegro - `(if (zerop ,obj) - nil - (values (excl:native-to-string - ,obj - ,@(if length (list :length length) (values)) - :truncate (not ,null-terminated-p)))) - #+lispworks - `(if (fli:null-pointer-p ,obj) - nil - (fli:convert-from-foreign-string - ,obj - ,@(if length (list :length length) (values)) - :null-terminated-p ,null-terminated-p - :external-format '(:latin-1 :eol-style :lf))) - #+cmu - `(cmucl-naturalize-cstring (alien:alien-sap ,obj) - :length ,length - :null-terminated-p ,null-terminated-p) - #+mcl - (declare (ignore null-terminated-p)) - #+mcl - `(if (ccl:%null-ptr-p ,obj) - nil - (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil))) - ) - -(defmacro convert-to-foreign-string (obj) - #+lispworks - `(if (null ,obj) - +null-cstring-pointer+ - (fli:convert-to-foreign-string ,obj)) - #+allegro - `(if (null ,obj) - 0 - (values (excl:string-to-native ,obj))) - #+cmu - (let ((size (gensym)) - (storage (gensym)) - (i (gensym))) - `(when (stringp ,obj) - (let* ((,size (length ,obj)) - (,storage (alien:make-alien char (1+ ,size)))) - (setq ,storage (alien:cast ,storage (* char))) - (dotimes (,i ,size) - (declare (fixnum ,i) - (optimize (speed 3) (safety 0))) - (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i)))) - (setf (alien:deref ,storage ,size) 0) - ,storage))) - #+mcl - `(if (null ,obj) - +null-cstring-pointer+ - (let ((ptr (new-ptr (1+ (length ,obj))))) - (ccl:%put-cstring ptr ,obj) - ptr)) - ) - - -(defmacro allocate-foreign-string (size &key (unsigned t)) - #+cmu - (let ((array-def (gensym))) - `(let ((,array-def (list 'alien:array 'c-call:char ,size))) - (eval `(alien:cast (alien:make-alien ,,array-def) - ,(if ,unsigned - '(* (alien:unsigned 8)) - '(* (alien:signed 8))))))) - #+lispworks - `(fli:allocate-foreign-object :type - ,(if unsigned - ''(:unsigned :char) - :char) - :nelems ,size) - #+allegro - (declare (ignore unsigned)) - #+allegro - `(ff:allocate-fobject :char :c ,size) - #+mcl - (declare (ignore unsigned)) - #+mcl - `(new-ptr ,size) - - ) - - -; I'm sure there must be a better way to write this... -(defmacro with-cstring ((foreign-string lisp-string) &body body) - `(if (stringp ,lisp-string) - (ccl:with-cstrs ((,foreign-string ,lisp-string)) - ,@body) - (let ((,foreign-string +null-cstring-pointer+)) - ,@body))) - - -(defmacro with-cstrings (bindings &rest body) - (if bindings - `(with-cstring ,(car bindings) - (with-cstrings ,(cdr bindings) - ,@body)) - `(progn ,@body))) - -(defmacro with-foreign-string ((foreign-string lisp-string) &body body) - (let ((result (gensym))) - `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string)) - (,result (progn ,@body))) - (declare (dynamic-extent ,foreign-string)) - (free-foreign-object ,foreign-string) - ,result))) - - - - - diff --git a/src/.cvsignore b/src/.cvsignore new file mode 100755 index 0000000..ca8d09f --- /dev/null +++ b/src/.cvsignore @@ -0,0 +1 @@ +.bin diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..31dc910 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,6 @@ +SUBDIRS := + +include ../Makefile.common + +.PHONY: distclean +distclean: clean diff --git a/src/aggregates.cl b/src/aggregates.cl new file mode 100644 index 0000000..bdc7704 --- /dev/null +++ b/src/aggregates.cl @@ -0,0 +1,188 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: aggregates.cl +;;;; Purpose: UFFI source to handle aggregate types +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: aggregates.cl,v 1.14 2002/09/30 07:51:01 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + +(defmacro def-enum (enum-name args &key (separator-string "#")) + "Creates a constants for a C type enum list, symbols are created +in the created in the current package. The symbol is the concatenation +of the enum-name name, separator-string, and field-name" + (let ((counter 0) + (cmds nil) + (constants nil)) + (declare (fixnum counter)) + (dolist (arg args) + (let ((name (if (listp arg) (car arg) arg)) + (value (if (listp arg) + (prog1 + (setq counter (cadr arg)) + (incf counter)) + (prog1 + counter + (incf counter))))) + (setq name (intern (concatenate 'string + (symbol-name enum-name) + separator-string + (symbol-name name)))) + (push `(uffi:def-constant ,name ,value) constants))) + (setf cmds (append '(progn) + #+allegro `((ff:def-foreign-type ,enum-name :int)) + #+lispworks `((fli:define-c-typedef ,enum-name :int)) + #+cmu `((alien:def-alien-type ,enum-name alien:signed)) + #+(and mcl (not openmcl)) `((def-mcl-type ,enum-name :integer)) + #+openmcl `((ccl::def-foreign-type ,enum-name :int)) + (nreverse constants))) + cmds)) + + +(defmacro def-array-pointer (name-array type) + #+allegro + `(ff:def-foreign-type ,name-array + (:array ,(convert-from-uffi-type type :array))) + #+lispworks + `(fli:define-c-typedef ,name-array + (:c-array ,(convert-from-uffi-type type :array))) + #+cmu + `(alien:def-alien-type ,name-array + (* ,(convert-from-uffi-type type :array))) + #+(and mcl (not openmcl)) + `(def-mcl-type ,name-array '(:array ,type)) + #+openmcl + `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array))) + ) + +(defun process-struct-fields (name fields) + (let (processed) + (dolist (field fields) + (let ((field-name (car field)) + (type (cadr field))) + (push (append (list field-name) + (if (eq type :pointer-self) + #+cmu `((* (alien:struct ,name))) + #+mcl `((:* (:struct ,name))) + #-(or cmu mcl) `((* ,name)) + `(,(convert-from-uffi-type type :struct)))) + processed))) + (nreverse processed))) + + +(defmacro def-struct (name &rest fields) + #+cmu + `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields))) + #+allegro + `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields))) + #+lispworks + `(fli:define-c-struct ,name ,@(process-struct-fields name fields)) + #+(and mcl (not openmcl)) + `(ccl:defrecord ,name ,@(process-struct-fields name fields nil)) + #+openmcl + `(ccl::def-foreign-type nil + (:struct ,name ,@(process-struct-fields name fields nil))) + ) + + +(defmacro get-slot-value (obj type slot) + #+(or lispworks cmu) (declare (ignore type)) + #+allegro + `(ff:fslot-value-typed ,type :c ,obj ,slot) + #+lispworks + `(fli:foreign-slot-value ,obj ,slot) + #+cmu + `(alien:slot ,obj ,slot) + #+mcl + `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) + ) + +#+mcl +(defmacro set-slot-value (obj type slot value) ;use setf to set values + `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value)) + +#+mcl +(defsetf get-slot-value set-slot-value) + + +(defmacro get-slot-pointer (obj type slot) + #+(or lispworks cmu) (declare (ignore type)) + #+allegro + `(ff:fslot-value-typed ,type :c ,obj ,slot) + #+lispworks + `(fli:foreign-slot-pointer ,obj ,slot) + #+cmu + `(alien:slot ,obj ,slot) + #+(and mcl (not openmcl)) + `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot)))) + #+openmcl + `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot))) + (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field))))) +) + +; so we could allow '(:array :long) or deref with other type like :long only +#+mcl +(defun array-type (type) + (let ((result type)) + (when (listp type) + (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type))) + (when (and (listp type-list) (eq (car type-list) :array)) + (setf result (cadr type-list))))) + result)) + + +(defmacro deref-array (obj type i) + "Returns a field from a row" + #+(or lispworks cmu) (declare (ignore type)) + #+cmu `(alien:deref ,obj ,i) + #+lispworks `(fli:dereference ,obj :index ,i) + #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i) + #+mcl + (let* ((array-type (array-type type)) + (local-type (convert-from-uffi-type array-type :allocation)) + (accessor (first (macroexpand `(ccl:pref obj ,local-type))))) + `(,accessor + ,obj + (* (the fixnum ,i) ,(size-of-foreign-type local-type)))) + ) + +; this expands to the %set-xx functions which has different params than %put-xx +#+mcl +(defmacro deref-array-set (obj type i value) + (let* ((array-type (array-type type)) + (local-type (convert-from-uffi-type array-type :allocation)) + (accessor (first (macroexpand `(ccl:pref obj ,local-type)))) + (settor (first (macroexpand `(setf (,accessor obj ,local-type) value))))) + `(,settor + ,obj + (* (the fixnum ,i) ,(size-of-foreign-type local-type)) + ,value))) + +#+mcl +(defsetf deref-array deref-array-set) + +(defmacro def-union (name &rest fields) + #+allegro + `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields))) + #+lispworks + `(fli:define-c-union ,name ,@(process-struct-fields name fields)) + #+cmu + `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields))) + #+(and mcl (not openmcl)) + `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t))) + #+openmcl + `(ccl::def-foreign-type nil + (:union ,name ,@(process-struct-fields name fields nil))) +) diff --git a/src/corman/corman-uffi.cl b/src/corman/corman-uffi.cl new file mode 100644 index 0000000..d91d41a --- /dev/null +++ b/src/corman/corman-uffi.cl @@ -0,0 +1,274 @@ +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" ++;;;; Date Started: Feb 2002 ++;;;; ++;;;; $Id: corman-uffi.cl,v 1.5 2002/09/30 07:52:34 kevin Exp $ ++;;;; ++;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ++;;;; ++;;;; UFFI users are granted the rights to distribute and use this software ++;;;; as governed by the terms of the Lisp Lesser GNU Public License ++;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ++;;;; ************************************************************************* ++ ++(in-package :cl-user) ++ ++(ct:defun-dll c-getenv ((lpname LPSTR) ++ (lpbuffer LPSTR) ++ (nsize LPDWORD)) ++ :library-name "kernel32.dll" ++ :return-type DWORD ++ :entry-name "GetEnvironmentVariableA" ++ :linkage-type :pascal) ++ ++(defun getenv (name) ++ (let ((nsizebuf (ct:malloc (sizeof :long))) ++ (buffer (ct:malloc 1)) ++ (cname (ct:lisp-string-to-c-string name))) ++ (setf (ct:cref lpdword nsizebuf 0) 0) ++ (let* ((needed-size (c-getenv cname buffer nsizebuf)) ++ (buffer1 (ct:malloc (1+ needed-size)))) ++ (setf (ct:cref lpdword nsizebuf 0) needed-size) ++ (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf)) ++ nil ++ (ct:c-string-to-lisp-string buffer1)) ++ (ct:free buffer1) ++ (ct:free nsizebuf))))) ++ ++(defun cl:user-homedir-pathname (&optional host) ++ (cond ((or (stringp host) ++ (and (consp host) ++ (every #'stringp host))) nil) ++ ((or (eq host :unspecific) ++ (null host)) ++ (let ((homedrive (getenv "HOMEDRIVE")) ++ (homepath (getenv "HOMEPATH"))) ++ (parse-namestring ++ (if (and (stringp homedrive) ++ (stringp homepath) ++ (= (length homedrive) 2) ++ (> (length homepath) 0)) ++ (concatenate 'string homedrive homepath "\\") ++ "C:\\")))) ++ (t (error "HOST must be a string, list of strings, NIL or :unspecific")))) ++ ++;| ++(uffi:def-function ("getenv" c-getenv) ++ ((name :cstring)) ++ :returning :cstring) ++ ++(defun my-getenv (key) ++ "Returns an environment variable, or NIL if it does not exist" ++ (check-type key string) ++ (uffi:with-cstring (key-native key) ++ (uffi:convert-from-cstring (c-getenv key-native)))) ++ ++#+examples-uffi ++(progn ++ (flet ((print-results (str) ++ (format t "~&(getenv ~S) => ~S" str (my-getenv str)))) ++ (print-results "USER") ++ (print-results "_FOO_"))) ++ ++ ++#+test-uffi ++(progn ++ (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv") ++ (util.test:test (and (stringp (my-getenv "USER")) ++ (< 0 (length (my-getenv "USER")))) ++ t :fail-info "Error retrieving getenv") ++) ++ ++|; +\ No newline at end of file +--- ./Makefile~ Tue Apr 9 20:03:18 2002 ++++ ./Makefile Tue Apr 9 20:38:03 2002 +@@ -64,3 +64,7 @@ + + wwwdist: dist + @./copy ++ ++TAGS: ++ if [ -f TAGS ]; then mv -f TAGS TAGS~; fi ++ find . -name \*.cl -exec /usr/bin/etags -a \{\} \; +--- ./set-logical.cl~ Tue Apr 9 20:03:20 2002 ++++ ./set-logical.cl Tue Apr 9 20:35:44 2002 +@@ -35,10 +35,10 @@ + #+clisp "clisp" + #+cmu "cmucl" + #+sbcl "sbcl" +- #+corman "corman" ++ #+cormanlisp "cormanlisp" + #+mcl "mcl" + #+openmcl "openmcl" +- #-(or allegro lispworks clisp cmu sbcl corman mcl openmcl) "unknown") ++ #-(or allegro lispworks clisp cmu sbcl cormanlisp mcl openmcl) "unknown") + + (defun set-logical-host-for-pathname (host base-pathname) + (setf (logical-pathname-translations host) +--- ./src/functions.cl~ Tue Apr 9 20:03:24 2002 ++++ ./src/functions.cl Tue Apr 9 21:00:07 2002 +@@ -3,7 +3,7 @@ + ;;;; FILE IDENTIFICATION + ;;;; + ;;;; Name: function.cl +-;;;; Purpose: UFFI source to C function defintions ++;;;; Purpose: UFFI source to C function definitions + ;;;; Programmer: Kevin M. Rosenberg + ;;;; Date Started: Feb 2002 + ;;;; +@@ -21,9 +21,8 @@ + + (defun process-function-args (args) + (if (null args) +- #+lispworks nil ++ #+(or lispworks cmu cormanlisp) nil + #+allegro '(:void) +- #+cmu nil + (let (processed) + (dolist (arg args) + (push (process-one-function-arg arg) processed)) +@@ -34,7 +33,7 @@ + (type (convert-from-uffi-type (cadr arg) :routine))) + #+cmu + (list name type :in) +- #+(or allegro lispworks) ++ #+(or allegro lispworks cormanlisp) + (if (and (listp type) (listp (car type))) + (append (list name) type) + (list name type)) +@@ -47,15 +46,15 @@ + + ;; name is either a string representing foreign name, or a list + ;; of foreign-name as a string and lisp name as a symbol +-(defmacro def-function (names args &key module returning) +- #+(or cmu allegro) (declare (ignore module)) ++(defmacro def-function (names args &key module returning calling-convention) ++ #+(or cmu allegro cormanlisp) (declare (ignore module)) + + (let* ((result-type (convert-from-uffi-type returning :return)) + (function-args (process-function-args args)) + (foreign-name (if (atom names) names (car names))) + (lisp-name (if (atom names) (make-lisp-name names) (cadr names)))) + +- #+allegro ++ #+allegro ; todo: calling-convention :stdcall + `(ff:def-foreign-call (,lisp-name ,foreign-name) + ,function-args + :returning ,(allegro-convert-return-type result-type) +@@ -70,7 +69,13 @@ + ,function-args + ,@(if module (list :module module) (values)) + :result-type ,result-type +- :calling-convention :cdecl) ++ :calling-convention ,calling-convention) ++ #+cormanlisp ++ `(ct:defun-dll ,lisp-name (,function-args) ++ :return-type ,result-type ++ ,@(if module (list :library-name module) (values)) ++ :entry-name ,foreign-name ++ :linkage-type ,calling-convention) ; we need :pascal + )) + + +--- ./src/primitives.cl~ Tue Apr 9 20:03:25 2002 ++++ ./src/primitives.cl Tue Apr 9 21:05:13 2002 +@@ -29,9 +29,9 @@ + (defmacro def-type (name type) + "Generates a (deftype) statement for CL. Currently, only CMUCL + supports takes advantage of this optimization." +- #+(or lispworks allegro) ++ #+(or lispworks allegro cormanlisp) + (declare (ignore type)) +- #+(or lispworks allegro) ++ #+(or lispworks allegro cormanlisp) + `(deftype ,name () t) + #+cmu + `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare))) +@@ -45,6 +45,7 @@ + #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type)) + #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type)) + #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type)) ++ #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type)) + ) + + (eval-when (:compile-toplevel :load-toplevel :execute) +@@ -66,7 +67,7 @@ + (:float . alien:single-float) + (:double . alien:double-float) + ) +- "Conversions in CMUCL or def-foreign-type are different thatn in def-function") ++ "Conversions in CMUCL for def-foreign-type are different that in def-function") + + + #+cmu +@@ -84,7 +85,7 @@ + (:long . c-call:long) (:unsigned-long . c-call:unsigned-long) + (:float . c-call:float) (:double . c-call:double) + (:array . alien:array))) +-#+allegro ++#+(or allegro cormanlisp) + (defconstant +type-conversion-list+ + '((* . *) (:void . :void) + (:short . :short) +@@ -129,7 +130,7 @@ + "Converts from a uffi type to an implementation specific type" + (if (atom type) + (cond +- #+allegro ++ #+(or allegro cormanlisp) + ((and (or (eq context :routine) (eq context :return)) + (eq type :cstring)) + (setq type '((* :char) integer))) +--- ./uffi.system~ Tue Apr 9 20:03:20 2002 ++++ ./uffi.system Tue Apr 9 20:36:14 2002 +@@ -27,7 +27,7 @@ + (merge-pathnames + (make-pathname + :directory +- #+(or cmu allegro lispworks) ++ #+(or cmu allegro lispworks cormanlisp) + '(:relative "src") + #+mcl + '(:relative "src" "mcl") + +--------------269CD5B1F75AF20CFDFE4FEE-- + +_______________________________________________ +UFFI-Devel mailing list +UFFI-Devel@b9.com +http://www.b9.com/mailman/listinfo/uffi-devel + diff --git a/src/functions.cl b/src/functions.cl new file mode 100644 index 0000000..a797a39 --- /dev/null +++ b/src/functions.cl @@ -0,0 +1,114 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: function.cl +;;;; Purpose: UFFI source to C function defintions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: functions.cl,v 1.10 2002/09/30 07:51:01 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + +(defun process-function-args (args) + (if (null args) + #+lispworks nil + #+allegro '(:void) + #+cmu nil + #+(and mcl (not openmcl)) nil + #+mcl (values nil nil) + + ;; args not null + #+(or lispworks allegro cmu (and mcl (not openmcl))) + (let (processed) + (dolist (arg args) + (push (process-one-function-arg arg) processed)) + (nreverse processed)) + #+openmcl + (let ((processed nil) + (params nil) + name type) + (dolist (arg args) + (setf name (car arg)) + (setf type (convert-from-uffi-type (cadr arg) :routine)) + ;;(when (and (listp type) (eq (car type) :address)) + ;;(setf type :address)) + (push name params) + (push type processed) + (push name processed)) + (values (nreverse params) (nreverse processed))) + )) + +(defun process-one-function-arg (arg) + (let ((name (car arg)) + (type (convert-from-uffi-type (cadr arg) :routine))) + #+cmu + (list name type :in) + #+(or allegro lispworks (and mcl (not openmcl))) + (if (and (listp type) (listp (car type))) + (append (list name) type) + (list name type)) + )) + + +(defun allegro-convert-return-type (type) + (if (and (listp type) (not (listp (car type)))) + (list type) + type)) + +;; name is either a string representing foreign name, or a list +;; of foreign-name as a string and lisp name as a symbol +(defmacro def-function (names args &key module returning) + #+(or cmu allegro mcl) (declare (ignore module)) + + (let* ((result-type (convert-from-uffi-type returning :return)) + (function-args (process-function-args args)) + (foreign-name (if (atom names) names (car names))) + (lisp-name (if (atom names) (make-lisp-name names) (cadr names)))) + + #+allegro + `(ff:def-foreign-call (,lisp-name ,foreign-name) + ,function-args + :returning ,(allegro-convert-return-type result-type) + :call-direct t + :strings-convert nil) + #+cmu + `(alien:def-alien-routine (,foreign-name ,lisp-name) + ,result-type + ,@function-args) + #+lispworks + `(fli:define-foreign-function (,lisp-name ,foreign-name :source) + ,function-args + ,@(if module (list :module module) (values)) + :result-type ,result-type + :calling-convention :cdecl) + #+(and mcl (not openmcl)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:define-entry-point (,lisp-name ,foreign-name) + ,function-args + ,result-type)) + #+(and openmcl darwinppc-target) + (setf foreign-name (concatenate 'string "_" foreign-name)) + #+openmcl + (multiple-value-bind (params args) (process-function-args args) + `(defun ,lisp-name ,params + (ccl::external-call ,foreign-name ,@args ,result-type))) + )) + + +(defun make-lisp-name (name) + (let ((converted (substitute #\- #\_ name))) + (intern + #+case-sensitive converted + #-case-sensitive (string-upcase converted)))) + + diff --git a/src/libraries.cl b/src/libraries.cl new file mode 100644 index 0000000..96807ee --- /dev/null +++ b/src/libraries.cl @@ -0,0 +1,110 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: libraries.cl +;;;; Purpose: UFFI source to load foreign libraries +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: libraries.cl,v 1.18 2002/09/30 07:51:01 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + +(defvar *loaded-libraries* nil + "List of foreign libraries loaded. Used to prevent reloading a library") + +(defun default-foreign-library-type () + "Returns string naming default library type for platform" + #+(or win32 mswindows) "dll" + #+macosx "dylib" + #-(or win32 mswindows macosx) "so" +) + +(defun find-foreign-library (names directories &key types drive-letters) + "Looks for a foreign library. directories can be a single +string or a list of strings of candidate directories. Use default +library type if type is not specified." + (unless types + (setq types (default-foreign-library-type))) + (unless (listp types) + (setq types (list types))) + (unless (listp names) + (setq names (list names))) + (unless (listp directories) + (setq directories (list directories))) + #+(or win32 mswindows) + (unless (listp drive-letters) + (setq drive-letters (list drive-letters))) + #-(or win32 mswindows) + (setq drive-letters '(nil)) + (dolist (drive-letter drive-letters) + (dolist (name names) + (dolist (dir directories) + (dolist (type types) + (let ((path (make-pathname + #+lispworks :host + #+lispworks (when drive-letter drive-letter) + #-lispworks :device + #-lispworks (when drive-letter drive-letter) + :name name + :type type + :directory + (etypecase dir + (pathname + (pathname-directory dir)) + (list + dir) + (string + (pathname-directory + (parse-namestring dir))))))) + (when (probe-file path) + (return-from find-foreign-library path))))))) + nil) + + +(defun load-foreign-library (filename &key module supporting-libraries + force-load) + #+allegro (declare (ignore module supporting-libraries)) + #+lispworks (declare (ignore supporting-libraries)) + #+cmu (declare (ignore module)) + #+openmcl (declare (ignore module supporting-libraries)) + + (when (and filename (probe-file filename)) + (if (pathnamep filename) ;; ensure filename is a string to check if + (setq filename (namestring filename))) ; already loaded + + (if (and (not force-load) + (find filename *loaded-libraries* :test #'string-equal)) + t ;; return T, but don't reload library + (progn + (when + #+cmu + (let ((type (pathname-type (parse-namestring filename)))) + (if (equal type "so") + (sys::load-object-file filename) + (alien:load-foreign filename + :libraries + (convert-supporting-libraries-to-string + supporting-libraries)))) + #+lispworks (fli:register-module module :real-name filename) + #+allegro (load filename) + #+openmcl (ccl:open-shared-library filename) + #+(and mcl (not openmcl)) (ccl:add-to-shared-library-search-path filename t) + + (push filename *loaded-libraries*) + t))))) + +(defun convert-supporting-libraries-to-string (libs) + (let (lib-load-list) + (dolist (lib libs) + (push (format nil "-l~A" lib) lib-load-list)) + (nreverse lib-load-list))) diff --git a/src/objects-mcl.cl b/src/objects-mcl.cl new file mode 100644 index 0000000..75eccb2 --- /dev/null +++ b/src/objects-mcl.cl @@ -0,0 +1,42 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: readmacros-mcl.cl +;;;; Purpose: UFFI source to handle objects and pointers +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: objects-mcl.cl,v 1.1 2002/09/30 07:51:01 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + +;; trap macros don't work right directly in the macros +(eval-when (:compile-toplevel :load-toplevel :execute) + + #+(and mcl (not openmcl)) + (defun new-ptr (size) + (#_NewPtr size)) + + #+(and mcl (not openmcl)) + (defun dispose-ptr (ptr) + (#_DisposePtr ptr)) + + #+openmcl + (defmacro new-ptr (size) + `(ccl::malloc ,size)) + + #+openmcl + (defmacro dispose-ptr (ptr) + `(ccl::free ,ptr)) + ) + + diff --git a/src/objects.cl b/src/objects.cl new file mode 100644 index 0000000..3500301 --- /dev/null +++ b/src/objects.cl @@ -0,0 +1,183 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: objects.cl +;;;; Purpose: UFFI source to handle objects and pointers +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: objects.cl,v 1.24 2002/09/30 07:51:01 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + +(defmacro allocate-foreign-object (type &optional (size :unspecified)) + "Allocates an instance of TYPE. If size is specified, then allocate +an array of TYPE with size SIZE. The TYPE parameter is evaluated." + (if (eq size :unspecified) + (progn + #+cmu + `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation)) + #+lispworks + `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate)) + #+allegro + `(ff:allocate-fobject ,(convert-from-uffi-type type :allocate) :c) + #+mcl + `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation))) + ) + (progn + #+cmu + `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) + #+lispworks + `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate) :nelems ,size) + #+allegro + `(ff:allocate-fobject '(:array ,(convert-from-uffi-type (eval type) :allocate) ,(eval size)) :c) + #+mcl + `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))) + ))) + +(defmacro free-foreign-object (obj) + #+cmu + `(alien:free-alien ,obj) + #+lispworks + `(fli:free-foreign-object ,obj) + #+allegro + `(ff:free-fobject ,obj) + #+mcl + `(dispose-ptr ,obj) + ) + +(defmacro null-pointer-p (obj) + #+lispworks `(fli:null-pointer-p ,obj) + #+allegro `(zerop ,obj) + #+cmu `(alien:null-alien ,obj) + #+mcl `(ccl:%null-ptr-p ,obj) + ) + +(defmacro size-of-foreign-type (type) + #+lispworks `(fli:size-of ,type) + #+allegro `(ff:sizeof-fobject ,type) + #+cmu `(alien:alien-size ,type) + #+clisp `(values (ffi:size-of ,type)) + #+(and mcl (not openmcl)) + `(let ((mcl-type (ccl:find-mactype ,type nil t))) + (if mcl-type + (ccl::mactype-record-size mcl-type) + (ccl::record-descriptor-length (ccl:find-record-descriptor ,type t t)))) ;error if not a record + #+opencml `(ccl::%foreign-type-or-record-size ,type :bytes) + ) + + +(defmacro make-null-pointer (type) + #+(or allegro cmu mcl) (declare (ignore type)) + + #+cmu `(system:int-sap 0) + #+allegro 0 + #+lispworks `(fli:make-pointer :address 0 :type ,type) + #+mcl `(ccl:%null-ptr) + ) + +(defmacro char-array-to-pointer (obj) + #+cmu `(alien:cast ,obj (* (alien:unsigned 8))) + #+lispworks `(fli:make-pointer :type '(:unsigned :char) + :address (fli:pointer-address ,obj)) + #+allegro obj + #+mcl obj + ) + +(defmacro deref-pointer (ptr type) + "Returns a object pointed" + #+(or cmu lispworks) (declare (ignore type)) + #+cmu `(alien:deref ,ptr) + #+lispworks `(fli:dereference ,ptr) + #+allegro `(ff:fslot-value-typed ,(convert-from-uffi-type type :deref) :c ,ptr) + #+mcl `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) + ) + +#+mcl +(defmacro deref-pointer-set (ptr type value) + `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value)) + +#+mcl +(defsetf deref-pointer deref-pointer-set) + +#+(or lispworks (and mcl (not openmcl))) ;; with LW, deref is a character +(defmacro ensure-char-character (obj) + obj) + +#+(or allegro cmu openmcl) +(defmacro ensure-char-character (obj) + `(code-char ,obj)) + +#+(or lispworks (and mcl (not openmcl))) +(defmacro ensure-char-integer (obj) + `(char-code ,obj)) + +#+(or allegro cmu openmcl) +(defmacro ensure-char-integer (obj) + obj) + +(defmacro pointer-address (obj) + #+cmu + `(system:sap-int (alien:alien-sap ,obj)) + #+lispworks + `(fli:pointer-address ,obj) + #+allegro + obj + #+mcl + `(ccl:%ptr-to-int ,obj) + ) + +;; TYPE is evaluated. +#-mcl +(defmacro with-foreign-object ((var type) &rest body) + #-(or cmu lispworks) ; default version + `(let ((,var (allocate-foreign-object ,type))) + (unwind-protect + (progn ,@body) + (free-foreign-object ,var))) + #+cmu + (let ((obj (gensym))) + `(alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate))) + (let ((,var (alien:addr ,obj))) + ,@body))) + #+lispworks + `(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type + (eval type) :allocate))) + ,@body) + ) + +#+mcl +(defmacro with-foreign-object ((var type) &rest body) + `(with-foreign-objects ((,var ,type)) + ,@body)) + +#-mcl +(defmacro with-foreign-objects (bindings &rest body) + (if bindings + `(with-foreign-object ,(car bindings) + (with-foreign-objects ,(cdr bindings) + ,@body)) + `(progn ,@body))) + +#+mcl +(defmacro with-foreign-objects (bindings &rest body) + (let ((params nil) type count) + (dolist (spec (reverse bindings)) ;keep order - macroexpands to let* + (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate)) + (setf count 1) + (when (and (listp type) (eq (first type) :array)) + (setf count (nth 2 type)) + (unless (integerp count) (error "Invalid size for array: ~a" type)) + (setf type (nth 1 type))) + (push (list (first spec) (* count (size-of-foreign-type type))) params)) + `(ccl:%stack-block ,params ,@body))) + diff --git a/src/package.cl b/src/package.cl new file mode 100644 index 0000000..abacbc8 --- /dev/null +++ b/src/package.cl @@ -0,0 +1,72 @@ +;;;; -*- 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 + )) diff --git a/src/primitives.cl b/src/primitives.cl new file mode 100644 index 0000000..9a982be --- /dev/null +++ b/src/primitives.cl @@ -0,0 +1,285 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: primitives.cl +;;;; Purpose: UFFI source to handle immediate types +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: primitives.cl,v 1.24 2002/09/30 07:51:01 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + +#+mcl +(defvar *keyword-package* (find-package "KEYWORD")) + +#+mcl +; MCL and OpenMCL expect a lot of FFI elements to be keywords (e.g. struct field names in OpenMCL) +; So this provides a function to convert any quoted symbols to keywords. +(defun keyword (obj) + (cond ((keywordp obj) + obj) + ((null obj) + nil) + ((symbolp obj) + (intern (symbol-name obj) *keyword-package*)) + ((and (listp obj) (eq (car obj) 'cl:quote)) + (keyword (cadr obj))) + ((stringp obj) + (intern obj *keyword-package*)) + (t + obj))) + +; Wrapper for unexported function we have to use +#+(and mcl (not openmcl)) +(defmacro def-mcl-type (name type) + `(ccl::def-mactype ,(keyword name) (ccl:find-mactype ,type))) + +(defmacro def-constant (name value &key (export nil)) + "Macro to define a constant and to export it" + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant ,name ,value) + ,(when export (list 'export `(quote ,name))) + ',name)) + +(defmacro def-type (name type) + "Generates a (deftype) statement for CL. Currently, only CMUCL +supports takes advantage of this optimization." + #+(or lispworks allegro mcl) + (declare (ignore type)) + #+(or lispworks allegro mcl) + `(deftype ,name () t) + #+cmu + `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare))) + #+sbcl + `(deftype ,name () '(sb-alien:alien ,(convert-from-uffi-type type :declare))) + ) + +(defmacro null-char-p (val) + "Returns T if character is NULL" + `(zerop ,val)) + +(defmacro def-foreign-type (name type) + #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type)) + #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type)) + #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type)) + #+sbcl `(sb-alien:def-alien-type ,name ,(convert-from-uffi-type type :type)) + #+mcl + (let ((type (convert-from-uffi-type uffi-type :type))) + (unless (or (keywordp type) (consp type)) + (setf type `(quote ,type))) + #+(and mcl (not openmcl)) + `(def-mcl-type ,(keyword name) ,type) + #+openmcl + `(ccl::def-foreign-type ,(keyword name) ,type)) + ) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar +type-conversion-hash+ (make-hash-table :size 20)) + #+(or cmu sbcl) (defvar +cmu-def-type-hash+ (make-hash-table :size 20)) + ) + +#+cmu +(defconstant +cmu-def-type-list+ + '((:char . (alien:signed 8)) + (:unsigned-char . (alien:unsigned 8)) + (:byte . (alien:signed 8)) + (:unsigned-byte . (alien:unsigned 8)) + (:short . (alien:signed 16)) + (:unsigned-short . (alien:unsigned 16)) + (:int . (alien:signed 32)) + (:unsigned-int . (alien:unsigned 32)) + (:long . (alien:signed 32)) + (:unsigned-long . (alien:unsigned 32)) + (:float . alien:single-float) + (:double . alien:double-float) + ) + "Conversions in CMUCL for def-foreign-type are different than in def-function") +#+sbcl +(defconstant +cmu-def-type-list+ + '((:char . (sb-alien:signed 8)) + (:unsigned-char . (sb-alien:unsigned 8)) + (:byte . (sb-alien:signed 8)) + (:unsigned-byte . (sb-alien:unsigned 8)) + (:short . (sb-alien:signed 16)) + (:unsigned-short . (sb-alien:unsigned 16)) + (:int . (sb-alien:signed 32)) + (:unsigned-int . (sb-alien:unsigned 32)) + (:long . (sb-alien:signed 32)) + (:unsigned-long . (sb-alien:unsigned 32)) + (:float . sb-alien:single-float) + (:double . sb-alien:double-float) + ) + "Conversions in SBCL for def-foreign-type are different than in def-function") + +(defparameter +type-conversion-list+ nil) + +#+cmu +(setq +type-conversion-list+ + '((* . *) (:void . c-call:void) + (:short . c-call:short) + (:pointer-void . (* t)) + (:cstring . c-call:c-string) + (:char . c-call:char) + (:unsigned-char . (alien:unsigned 8)) + (:byte . (alien:signed 8)) + (:unsigned-byte . (alien:unsigned 8)) + (:short . c-call:unsigned-short) + (:unsigned-short . c-call:unsigned-short) + (:int . alien:integer) (:unsigned-int . c-call:unsigned-int) + (:long . c-call:long) (:unsigned-long . c-call:unsigned-long) + (:float . c-call:float) (:double . c-call:double) + (:array . alien:array))) + +#+sbcl +(setq +type-conversion-list+ + '((* . *) (:void . void) + (:short . short) + (:pointer-void . (* t)) + (:cstring . c-string) + (:char . char) + (:unsigned-char . (sb-alien:unsigned 8)) + (:byte . (sb-alien:signed 8)) + (:unsigned-byte . (sb-alien:unsigned 8)) + (:short . unsigned-short) + (:unsigned-short . unsigned-short) + (:int . integer) (:unsigned-int . unsigned-int) + (:long . long) (:unsigned-long . unsigned-long) + (:float . float) (:double . double) + (:array . array))) + +#+allegro +(setq +type-conversion-list+ + '((* . *) (:void . :void) + (:short . :short) + (:pointer-void . (* :void)) + (:cstring . (* :unsigned-char)) + (:byte . :char) + (:unsigned-byte . :unsigned-byte) + (:char . :char) + (:unsigned-char . :unsigned-char) + (:int . :int) (:unsigned-int . :unsigned-int) + (:long . :long) (:unsigned-long . :unsigned-long) + (:float . :float) (:double . :double) + (:array . :array))) + +#+lispworks +(setq +type-conversion-list+ + '((* . :pointer) (:void . :void) + (:short . :short) + (:pointer-void . (:pointer :void)) + (:cstring . (:reference-pass (:ef-mb-string :external-format :latin-1) + :allow-null t)) + (:cstring-returning . (:reference (:ef-mb-string :external-format :latin-1) :allow-null t)) + (:byte . :byte) + (:unsigned-byte . (:unsigned :byte)) + (:char . :char) + (:unsigned-char . (:unsigned :char)) + (:int . :int) (:unsigned-int . (:unsigned :int)) + (:long . :long) (:unsigned-long . (:unsigned :long)) + (:float . :float) (:double . :double) + (:array . :c-array))) + +#+(and mcl (not openmcl)) +(defconstant +type-conversion-list+ + '((* . :pointer) (:void . :void) + (:short . :short) (:unsigned-short . :unsigned-short) + (:pointer-void . :pointer) + (:cstring . :string) + (:char . :character) + (:unsigned-char . :unsigned-byte) + (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte) + (:int . :long) (:unsigned-int . :unsigned-long) + (:long . :long) (:unsigned-long . :unsigned-long) + (:float . :single-float) (:double . :double-float) + (:array . :array))) + +#+openmcl +(defconstant +type-conversion-list+ + '((* . :address) (:void . :void) + (:short . :short) (:unsigned-short . :unsigned-short) + (:pointer-void . :address) + (:cstring . :address) + (:char . :signed-char) + (:unsigned-char . :unsigned-char) + (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte) + (:int . :int) (:unsigned-int . :unsigned-int) + (:long . :long) (:unsigned-long . :unsigned-long) + (:long-long . :signed-doubleword) (:unsigned-long-long . :unsigned-doubleword) + (:float . :single-float) (:double . :double-float) + (:array . :array))) + +(dolist (type +type-conversion-list+) + (setf (gethash (car type) +type-conversion-hash+) (cdr type))) + +#+(or cmu sbcl) +(dolist (type +cmu-def-type-list+) + (setf (gethash (car type) +cmu-def-type-hash+) (cdr type))) + +(defun basic-convert-from-uffi-type (type) + (let ((found-type (gethash type +type-conversion-hash+))) + (if found-type + found-type + #-mcl type + #+mcl (keyword type)))) + +(defun %convert-from-uffi-type (type context) + "Converts from a uffi type to an implementation specific type" + (if (atom type) + (cond + #+allegro + ((and (or (eq context :routine) (eq context :return)) + (eq type :cstring)) + (setq type '((* :char) integer))) + #+(or cmu sbcl) + ((eq context :type) + (let ((cmu-type (gethash type +cmu-def-type-hash+))) + (if cmu-type + cmu-type + (basic-convert-from-uffi-type type)))) + #+lispworks + ((and (eq context :return) + (eq type :cstring)) + (basic-convert-from-uffi-type :cstring-returning)) + #+(and mcl (not openmcl)) + ((and (eq type :void) (eq context :return)) nil) + (t + (basic-convert-from-uffi-type type))) + (let ((sub-type (car type))) + (case sub-type + (cl:quote + (convert-from-uffi-type (cadr type) context)) + (:struct-pointer + #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct))) + #-mcl (%convert-from-uffi-type (list '* (cadr type)) :struct) + ) + (:struct + #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct)) + #-mcl (%convert-from-uffi-type (cadr type) :struct) + ) + (t + (cons (%convert-from-uffi-type (first type) context) + (%convert-from-uffi-type (rest type) context))))))) + +(defun convert-from-uffi-type (type context) + (let ((result (%convert-from-uffi-type type context))) + (cond + ((atom result) result) + #+openmcl + ((eq (car result) :address) + (if (eq context :struct) + (append '(:*) (cdr result)) + :address)) + #+(and mcl (not openmcl)) + ((and (eq (car result) :pointer) (eq context :allocation) :pointer)) + (t result)))) + diff --git a/src/readmacros-mcl.cl b/src/readmacros-mcl.cl new file mode 100644 index 0000000..74dc32f --- /dev/null +++ b/src/readmacros-mcl.cl @@ -0,0 +1,39 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: readmacros-mcl.cl +;;;; Purpose: This file holds functions using read macros for MCL +;;;; Programmer: Kevin M. Rosenberg/John Desoi +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: readmacros-mcl.cl,v 1.1 2002/09/30 07:56:21 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + + +;; trap macros don't work right directly in the macros +#+(and mcl (not openmcl)) +(defun new-ptr (size) + (#_NewPtr size)) + +#+(and mcl (not openmcl)) +(defun dispose-ptr (ptr) + (#_DisposePtr ptr)) + +#+openmcl +(defmacro new-ptr (size) + `(ccl::malloc ,size)) + +#+openmcl +(defmacro dispose-ptr (ptr) + `(ccl::free ,ptr)) + diff --git a/src/readmacros-mcl.lisp b/src/readmacros-mcl.lisp new file mode 100644 index 0000000..ac20c36 --- /dev/null +++ b/src/readmacros-mcl.lisp @@ -0,0 +1,39 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: readmacros-mcl.cl +;;;; Purpose: This file holds functions using read macros for MCL +;;;; Programmer: Kevin M. Rosenberg/John Desoi +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: readmacros-mcl.lisp,v 1.1 2002/09/30 07:51:01 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + + +;; trap macros don't work right directly in the macros +#+(and mcl (not openmcl)) +(defun new-ptr (size) + (#_NewPtr size)) + +#+(and mcl (not openmcl)) +(defun dispose-ptr (ptr) + (#_DisposePtr ptr)) + +#+openmcl +(defmacro new-ptr (size) + `(ccl::malloc ,size)) + +#+openmcl +(defmacro dispose-ptr (ptr) + `(ccl::free ,ptr)) + diff --git a/src/strings.cl b/src/strings.cl new file mode 100644 index 0000000..b47b863 --- /dev/null +++ b/src/strings.cl @@ -0,0 +1,231 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: strings.cl +;;;; Purpose: UFFI source to handle strings, cstring and foreigns +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: strings.cl,v 1.22 2002/09/30 07:51:01 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + + +(defvar +null-cstring-pointer+ + #+cmu nil + #+allegro 0 + #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char)) + #+mcl (ccl:%nul-ptr) + #-(or cmu allegro lispworks mcl) nil +) + +(defmacro convert-from-cstring (obj) + "Converts a string from a c-call. Same as convert-from-foreign-string, except +that LW/CMU automatically converts strings from c-calls." + #+cmu obj + #+lispworks obj + #+allegro + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (zerop ,stored) + nil + (values (excl:native-to-string ,stored))))) + #+mcl + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (ccl:%null-ptr-p ,stored) + nil + (values (ccl:%get-cstring ,stored))))) + ) + +(defmacro convert-to-cstring (obj) + #+cmu obj + #+lispworks obj + #+allegro + `(if (null ,obj) + 0 + (values (excl:string-to-native ,obj))) + #+mcl + `(if (null ,obj) + +null-cstring-pointer+ + (let ((ptr (new-ptr (1+ (length ,obj))))) + (ccl:%put-cstring ptr ,obj) + ptr)) + ) + +(defmacro free-cstring (obj) + #+cmu (declare (ignore obj)) + #+lispworks (declare (ignore obj)) + #+allegro + `(unless (zerop obj) + (ff:free-fobject ,obj)) + #+mcl + `(unless (ccl:%null-ptr-p ,obj) + (dispose-ptr ,obj)) + ) + +(defmacro with-cstring ((cstring lisp-string) &body body) + #+cmu + `(let ((,cstring ,lisp-string)) ,@body) + #+lispworks + `(let ((,cstring ,lisp-string)) ,@body) + #+allegro + (let ((acl-native (gensym))) + `(excl:with-native-string (,acl-native ,lisp-string) + (let ((,cstring (if ,lisp-string ,acl-native 0))) + ,@body))) + #+mcl + `(if (stringp ,lisp-string) + (ccl:with-cstrs ((,foreign-string ,lisp-string)) + ,@body) + (let ((,foreign-string +null-cstring-pointer+)) + ,@body)) + ) + +(defmacro with-cstrings (bindings &rest body) + (if bindings + `(with-cstring ,(car bindings) + (with-cstrings ,(cdr bindings) + ,@body)) + `(progn ,@body))) + +;;; Foreign string functions + +(defmacro convert-to-foreign-string (obj) + #+lispworks + `(if (null ,obj) + +null-cstring-pointer+ + (fli:convert-to-foreign-string ,obj)) + #+allegro + `(if (null ,obj) + 0 + (values (excl:string-to-native ,obj))) + #+cmu + (let ((size (gensym)) + (storage (gensym)) + (i (gensym))) + `(etypecase ,obj + (null + (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8)))) + (string + (let* ((,size (length ,obj)) + (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size)))) + (setq ,storage (alien:cast ,storage (* (alien:unsigned 8)))) + (locally + (declare (optimize (speed 3) (safety 0))) + (dotimes (,i ,size) + (declare (fixnum ,i)) + (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i)))) + (setf (alien:deref ,storage ,size) 0)) + ,storage)))) + #+mcl + `(if (null ,obj) + +null-cstring-pointer+ + (let ((ptr (new-ptr (1+ (length ,obj))))) + (ccl:%put-cstring ptr ,obj) + ptr)) + ) + + +;; Either length or null-terminated-p must be non-nil +(defmacro convert-from-foreign-string (obj &key + length + (null-terminated-p t)) + #+allegro + `(if (zerop ,obj) + nil + (values (excl:native-to-string + ,obj + ,@(if length (list :length length) (values)) + :truncate (not ,null-terminated-p)))) + #+lispworks + `(if (fli:null-pointer-p ,obj) + nil + (fli:convert-from-foreign-string + ,obj + ,@(if length (list :length length) (values)) + :null-terminated-p ,null-terminated-p + :external-format '(:latin-1 :eol-style :lf))) + #+cmu + `(if (null-pointer-p ,obj) + nil + (cmucl-naturalize-cstring (alien:alien-sap ,obj) + :length ,length + :null-terminated-p ,null-terminated-p)) + #+mcl + (declare (ignore null-terminated-p)) + #+mcl + `(if (ccl:%null-ptr-p ,obj) + nil + (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil))) + ) + + + +(defmacro allocate-foreign-string (size &key (unsigned t)) + #+cmu + (let ((array-def (gensym))) + `(let ((,array-def (list 'alien:array 'c-call:char ,size))) + (eval `(alien:cast (alien:make-alien ,,array-def) + ,(if ,unsigned + '(* (alien:unsigned 8)) + '(* (alien:signed 8))))))) + #+lispworks + `(fli:allocate-foreign-object :type + ,(if unsigned + ''(:unsigned :char) + :char) + :nelems ,size) + #+allegro + (declare (ignore unsigned)) + #+allegro + `(ff:allocate-fobject :char :c ,size) + #+mcl + (declare (ignore unsigned)) + #+mcl + `(new-ptr ,size) + ) + +(defmacro with-foreign-string ((foreign-string lisp-string) &body body) + (let ((result (gensym))) + `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string)) + (,result (progn ,@body))) + (declare (dynamic-extent ,foreign-string)) + (free-foreign-object ,foreign-string) + ,result))) + + +;; Modified from CMUCL's source to handle non-null terminated strings +#+cmu +(defun cmucl-naturalize-cstring (sap &key + length + (null-terminated-p t)) + (declare (type system:system-area-pointer sap)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let ((null-terminated-length + (when null-terminated-p + (loop + for offset of-type fixnum upfrom 0 + until (zerop (system:sap-ref-8 sap offset)) + finally (return offset))))) + (if length + (if (and null-terminated-length + (> (the fixnum length) (the fixnum null-terminated-length))) + (setq length null-terminated-length)) + (setq length null-terminated-length))) + (let ((result (make-string length))) + (kernel:copy-from-system-area sap 0 + result (* vm:vector-data-offset + vm:word-bits) + (* length vm:byte-bits)) + result))) diff --git a/uffi.asd b/uffi.asd index a373571..dfb8608 100644 --- a/uffi.asd +++ b/uffi.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: uffi.asd,v 1.15 2002/09/25 12:44:59 kevin Exp $ +;;;; $Id: uffi.asd,v 1.16 2002/09/30 07:51:00 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -19,7 +19,7 @@ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :asdf) -#+(or allegro lispworks cmu openmcl mcl) +#+(or allegro lispworks cmu mcl) (defsystem uffi :name "cl-uffi" :author "Kevin M. Rosenberg " @@ -33,27 +33,16 @@ (pushnew :uffi cl:*features*)) :components - ( - #+(or cmu sbcl allegro lispworks) - (:module :src-main - :components - ((:file "package") - (:file "primitives" :depends-on ("package")) - (:file "strings" :depends-on ("primitives")) - (:file "objects" :depends-on ("primitives")) - (:file "aggregates" :depends-on ("primitives")) - (:file "functions" :depends-on ("primitives")) - (:file "libraries" :depends-on ("package")))) - #+mcl - (:module :src-mcl - :components - ((:file "package") - (:file "primitives" :depends-on ("package")) - (:file "strings" :depends-on ("primitives")) - (:file "objects" :depends-on ("primitives")) - (:file "aggregates" :depends-on ("primitives")) - (:file "functions" :depends-on ("primitives")) - (:file "libraries" :depends-on ("package")))) + ((:module :src + :components + ((:file "package") + (:file "primitives" :depends-on ("package")) + #+mcl (:file "readmacros-mcl" :depends-on ("package")) + (:file "strings" :depends-on ("primitives")) + (:file "objects" :depends-on ("primitives")) + (:file "aggregates" :depends-on ("primitives")) + (:file "functions" :depends-on ("primitives")) + (:file "libraries" :depends-on ("package")))) #+cormanlisp (:module :src-corman :components @@ -61,11 +50,11 @@ )) -#+(or allegro lispworks cmu openmcl mcl) +#+(or allegro lispworks cmu mcl) (defmethod source-file-type ((c cl-source-file) (s (eql (find-system :uffi)))) "cl") -#+(or allegro lispworks cmu openmcl mcl) +#+(or allegro lispworks cmu mcl) (when (ignore-errors (find-class 'load-compiled-op)) (defmethod perform :after ((op load-compiled-op) (c (eql (find-system :uffi)))) (pushnew :uffi cl:*features*)))