From: Kevin M. Rosenberg Date: Fri, 23 Aug 2002 15:34:51 +0000 (+0000) Subject: r2385: *** empty log message *** X-Git-Tag: v1.6.1~327 X-Git-Url: http://git.kpe.io/?p=uffi.git;a=commitdiff_plain;h=93d37518cbd27aa8b7f313bb89b9523d5a40ec88 r2385: *** empty log message *** --- diff --git a/ChangeLog b/ChangeLog index 7c7c0f4..0fa5816 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,31 +1,35 @@ +2002-08-25 Kevin Rosenberg (kevin@rosenberg.net) + - Restructure directories to attempt to properly handle both + Common Lisp Controller and non-CLC systems + 2002-08-17 Kevin Rosenberg (kevin@rosenberg.net) - add uffi.asd for ASDF users 2002-08-01 Kevin Rosenberg (kevin@rosenberg.net) - * Restructure directories to improve Common Lisp Controller v3 + - Restructure directories to improve Common Lisp Controller v3 compatibility 2002-07-25 Kevin Rosenberg (kevin@rosenberg.net) - * Rework handling of logical pathnames. - * Move run-examples.cl to examples directory. + - Rework handling of logical pathnames. + - Move run-examples.cl to examples directory. 2002-06-28 Kevin Rosenberg (kevin@rosenberg.net) - * Added size-of-foreign-type function. + - Added size-of-foreign-type function. 2002-06-26 Kevin Rosenberg (kevin@rosenberg.net) - * Fix bug in Lispworks allocate-foreign-object - * Added new :unsigned-byte type. Made :byte signed. + - Fix bug in Lispworks allocate-foreign-object + - Added new :unsigned-byte type. Made :byte signed. 2002-04-27 Kevin Rosenberg (kevin@rosenberg.net) - * misc files + - misc files First debian version 2002-04-23 Kevin Rosenberg (kevin@rosenberg.net) - * doc/* + - doc/* Updated to debian docbook catalog 2002-04-23 John DeSoi (desoi@mac.com) diff --git a/debian/changelog b/debian/changelog index e86cda0..d4c85a4 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +cl-uffi (0.6.2-1) unstable; urgency=low + + * New upstream version. Restructure directories once again to handle + non-CLC systems. + + -- Kevin M. Rosenberg Fri, 23 Aug 2002 09:33:14 -0600 + cl-uffi (0.6.1-1) unstable; urgency=low * Add uffi.asd file to upstream for ASDF users. 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..0dbea7d --- /dev/null +++ b/src/Makefile @@ -0,0 +1,6 @@ +SUBDIRS := mcl + +include ../Makefile.common + +.PHONY: distclean +distclean: clean diff --git a/src/aggregates.cl b/src/aggregates.cl new file mode 100644 index 0000000..84de957 --- /dev/null +++ b/src/aggregates.cl @@ -0,0 +1,125 @@ +;;;; -*- 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.12 2002/08/23 15:28:52 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + +(defmacro def-enum (enum-name args &key (separator-string "#")) + "Creates a constants for a C type enum list, symbols are created +in the created in the current package. The symbol is the concatenation +of the enum-name name, separator-string, and field-name" + (let ((counter 0) + (cmds nil) + (constants nil)) + (declare (fixnum counter)) + (dolist (arg args) + (let ((name (if (listp arg) (car arg) arg)) + (value (if (listp arg) + (prog1 + (setq counter (cadr arg)) + (incf counter)) + (prog1 + counter + (incf counter))))) + (setq name (intern (concatenate 'string + (symbol-name enum-name) + separator-string + (symbol-name name)))) + (push `(uffi:def-constant ,name ,value) constants))) + (setf cmds (append '(progn) + #+allegro `((ff:def-foreign-type ,enum-name :int)) + #+lispworks `((fli:define-c-typedef ,enum-name :int)) + #+cmu `((alien:def-alien-type ,enum-name alien:signed)) + (nreverse constants))) + cmds)) + + +(defmacro def-array-pointer (name-array type) + #+allegro + `(ff:def-foreign-type ,name-array + (:array ,(convert-from-uffi-type type :array))) + #+lispworks + `(fli:define-c-typedef ,name-array + (:c-array ,(convert-from-uffi-type type :array))) + #+cmu + `(alien:def-alien-type ,name-array + (* ,(convert-from-uffi-type type :array))) + ) + +(defun process-struct-fields (name fields) + (let (processed) + (dolist (field fields) + (let ((field-name (car field)) + (type (cadr field))) + (push (append (list field-name) + (if (eq type :pointer-self) + #+cmu `((* (alien:struct ,name))) + #-cmu `((* ,name)) + `(,(convert-from-uffi-type type :struct)))) + processed))) + (nreverse processed))) + + +(defmacro def-struct (name &rest fields) + #+cmu + `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields))) + #+allegro + `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields))) + #+lispworks + `(fli:define-c-struct ,name ,@(process-struct-fields name fields)) + ) + + +(defmacro get-slot-value (obj type slot) + #+(or lispworks cmu) (declare (ignore type)) + #+allegro + `(ff:fslot-value-typed ,type :c ,obj ,slot) + #+lispworks + `(fli:foreign-slot-value ,obj ,slot) + #+cmu + `(alien:slot ,obj ,slot) + ) + +(defmacro get-slot-pointer (obj type slot) + #+(or lispworks cmu) (declare (ignore type)) + #+allegro + `(ff:fslot-value-typed ,type :c ,obj ,slot) + #+lispworks + `(fli:foreign-slot-pointer ,obj ,slot) + #+cmu + `(alien:slot ,obj ,slot) + ) + +(defmacro deref-array (obj type i) + "Returns a field from a row" + #+(or lispworks cmu) (declare (ignore type)) + #+cmu `(alien:deref ,obj ,i) + #+lispworks `(fli:dereference ,obj :index ,i) + #+allegro `(ff:fslot-value-typed ,type :c ,obj ,i) + ) + +(defmacro def-union (name &rest fields) + #+allegro + `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields))) + #+lispworks + `(fli:define-c-union ,name ,@(process-struct-fields name fields)) + #+cmu + `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields))) +) + + diff --git a/src/corman/corman-uffi.cl b/src/corman/corman-uffi.cl new file mode 100644 index 0000000..b5101a2 --- /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.3 2002/08/23 15:28:20 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..70e1881 --- /dev/null +++ b/src/functions.cl @@ -0,0 +1,83 @@ +;;;; -*- 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.8 2002/08/23 15:28:52 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/libraries.cl b/src/libraries.cl new file mode 100644 index 0000000..33cfa76 --- /dev/null +++ b/src/libraries.cl @@ -0,0 +1,107 @@ +;;;; -*- 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.16 2002/08/23 15:28:52 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + +(defvar *loaded-libraries* nil + "List of foreign libraries loaded. Used to prevent reloading a library") + +(defun default-foreign-library-type () + "Returns string naming default library type for platform" + #+(or win32 mswindows) "dll" + #-(or win32 mswindows) "so") + +(defun find-foreign-library (names directories &key types drive-letters) + "Looks for a foreign library. directories can be a single +string or a list of strings of candidate directories. Use default +library type if type is not specified." + (unless types + (setq types (default-foreign-library-type))) + (unless (listp types) + (setq types (list types))) + (unless (listp names) + (setq names (list names))) + (unless (listp directories) + (setq directories (list directories))) + #+(or win32 mswindows) + (unless (listp drive-letters) + (setq drive-letters (list drive-letters))) + #-(or win32 mswindows) + (setq drive-letters '(nil)) + (dolist (drive-letter drive-letters) + (dolist (name names) + (dolist (dir directories) + (dolist (type types) + (let ((path (make-pathname + #+lispworks :host + #+lispworks (when drive-letter drive-letter) + #-lispworks :device + #-lispworks (when drive-letter drive-letter) + :name name + :type type + :directory + (etypecase dir + (pathname + (pathname-directory dir)) + (list + dir) + (string + (pathname-directory + (parse-namestring dir))))))) + (when (probe-file path) + (return-from find-foreign-library path))))))) + nil) + + +(defun load-foreign-library (filename &key module supporting-libraries + force-load) + #+allegro (declare (ignore module supporting-libraries)) + #+lispworks (declare (ignore supporting-libraries)) + #+cmu (declare (ignore module)) + + (when (and filename (probe-file filename)) + (if (pathnamep filename) ;; ensure filename is a string to check if + (setq filename (namestring filename))) ; already loaded + + (if (and (not force-load) + (find filename *loaded-libraries* :test #'string-equal)) + t ;; return T, but don't reload library + (progn + #+cmu + (let ((type (pathname-type (parse-namestring filename)))) + (if (equal type "so") + (sys::load-object-file filename) + (alien:load-foreign filename + :libraries + (convert-supporting-libraries-to-string + supporting-libraries)))) + + #+lispworks (fli:register-module module + :real-name filename) + #+allegro (load filename) + + (push filename *loaded-libraries*) + t))) + ) + +(defun convert-supporting-libraries-to-string (libs) + (let (lib-load-list) + (dolist (lib libs) + (push (format nil "-l~A" lib) lib-load-list)) + (nreverse lib-load-list))) diff --git a/src/mcl/Makefile b/src/mcl/Makefile new file mode 100644 index 0000000..ce6118b --- /dev/null +++ b/src/mcl/Makefile @@ -0,0 +1,6 @@ +SUBDIRS := + +include ../../Makefile.common + +.PHONY: distclean +distclean: clean diff --git a/src/mcl/aggregates.cl b/src/mcl/aggregates.cl new file mode 100644 index 0000000..7973d10 --- /dev/null +++ b/src/mcl/aggregates.cl @@ -0,0 +1,122 @@ +;;;; -*- 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.6 2002/08/23 15:28:11 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and John DeSoi +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + + + +(defmacro def-enum (enum-name args &key (separator-string "#")) + "Creates a constants for a C type enum list, symbols are created +in the created in the current package. The symbol is the concatenation +of the enum-name name, separator-string, and field-name" + (let ((counter 0) + (cmds nil) + (constants nil)) + (declare (fixnum counter)) + (dolist (arg args) + (let ((name (if (listp arg) (car arg) arg)) + (value (if (listp arg) + (prog1 + (setq counter (cadr arg)) + (incf counter)) + (prog1 + counter + (incf counter))))) + (setq name (intern (concatenate 'string + (symbol-name enum-name) + separator-string + (symbol-name name)))) + (push `(uffi:def-constant ,name ,value) constants))) + (setf cmds (append '(progn) + #+allegro `((ff:def-foreign-type ,enum-name :int)) + #+lispworks `((fli:define-c-typedef ,enum-name :int)) + #+cmu `((alien:def-alien-type ,enum-name alien:signed)) + #+mcl `((def-mcl-type ,enum-name :integer)) + (nreverse constants))) + cmds)) + + + +(defmacro def-array-pointer (name-array type) + `(def-mcl-type ,name-array '(:array ,type))) + + +; this is how rref expands array slot access (minus adding the struct offset) +(defmacro deref-array (obj type i) + "Returns a field from a row" + `(,(accessor-symbol type :get) ,obj (* (the fixnum ,i) ,(foreign-object-size type)))) + +(defmacro deref-array-set (obj type i value) + `(,(accessor-symbol type :set) ,obj ,value (* (the fixnum ,i) ,(foreign-object-size type)))) + +(defsetf deref-array deref-array-set) + + +(defun process-struct-fields (name fields variant) + (let (processed) + (dolist (field fields) + (let* ((field-name (car field)) + (type (cadr field)) + (def (append (list field-name) + (if (eq type :pointer-self) + #+cmu `((* (alien:struct ,name))) + #-cmu `((* ,name)) + `(,(convert-from-uffi-type type :struct)))))) + (if variant + (push (list def) processed) + (push def processed)))) + (nreverse processed))) + + +(defmacro def-struct (name &rest fields) + `(ccl:defrecord ,name ,@(process-struct-fields name fields nil))) + + +(defmacro def-union (name &rest fields) + `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))) + + +; Assuming everything is pointer based - no support for Mac handles +(defmacro get-slot-value (obj type slot) ;use setf to set values + `(ccl:pref ,obj ,(read-from-string (format nil "~a.~a" type slot)))) + + +(defmacro get-slot-pointer (obj type slot) + `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))) + + + +#| a few simple tests +(def-union union + (l1 :long) + (s1 :short)) + +(def-struct struct + (s1 :short) + (l1 :long) + (u1 :union)) + +(defvar s (allocate-foreign-object :struct)) +(setf (get-slot-value s :struct :s1) 3) +(get-slot-value s :struct :s1) +(setf (get-slot-value s :struct :u1.s1) 5) +(get-slot-value s :struct :u1.s1) + +|# \ No newline at end of file diff --git a/src/mcl/functions.cl b/src/mcl/functions.cl new file mode 100644 index 0000000..7712caa --- /dev/null +++ b/src/mcl/functions.cl @@ -0,0 +1,70 @@ +;;;; -*- 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.5 2002/08/23 15:28:11 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and John DeSoi +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + +(defun process-function-args (args) + (if (null args) + #+lispworks nil + #+allegro '(:void) + #+cmu nil + #+mcl nil + (let (processed) + (dolist (arg args) + (push (process-one-function-arg arg) processed)) + (nreverse processed)))) + +(defun process-one-function-arg (arg) + (let ((name (car arg)) + (type (convert-from-uffi-type (cadr arg) :routine))) + (if (and (listp type) (listp (car type))) + (append (list name) type) + (list name type)) + )) + +(defun allegro-convert-return-type (type) + (if (and (listp type) (not (listp (car type)))) + (list type) + type)) + +;; name is either a string representing foreign name, or a list +;; of foreign-name as a string and lisp name as a symbol + + +(defmacro def-function (names args &key module returning) + (declare (ignore module)) + + (let* ((result-type (convert-from-uffi-type returning :return)) + (function-args (process-function-args args)) + (foreign-name (if (atom names) names (car names))) + (lisp-name (if (atom names) (make-lisp-name names) (cadr names)))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:define-entry-point (,lisp-name ,foreign-name) + ,function-args + ,result-type)))) + + +(defun make-lisp-name (name) + (let ((converted (substitute #\- #\_ name))) + (intern + #+case-sensitive converted + #-case-sensitive (string-upcase converted)))) + + diff --git a/src/mcl/libraries.cl b/src/mcl/libraries.cl new file mode 100644 index 0000000..ba0107f --- /dev/null +++ b/src/mcl/libraries.cl @@ -0,0 +1,80 @@ +;;;; -*- 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.7 2002/08/23 15:28:11 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and John DeSoi +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + +(defvar *loaded-libraries* nil + "List of foreign libraries loaded. Used to prevent reloading a library") + +;in MCL calling this more than once for the same library does not do anything +(defmacro load-foreign-library (filename &key module supporting-libraries) + (declare (ignore module supporting-libraries)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (when (ccl:add-to-shared-library-search-path ,filename t) + (pushnew ,filename *loaded-libraries*)))) + +;; Copied directly from main source without MCL specializations +(defun find-foreign-library (names directories &key types drive-letters) + "Looks for a foreign library. directories can be a single +string or a list of strings of candidate directories. Use default +library type if type is not specified." + (unless types + (setq types (default-foreign-library-type))) + (unless (listp types) + (setq types (list types))) + (unless (listp names) + (setq names (list names))) + (unless (listp directories) + (setq directories (list directories))) + #+(or win32 mswindows) + (unless (listp drive-letters) + (setq drive-letters (list drive-letters))) + #-(or win32 mswindows) + (setq drive-letters '(nil)) + (dolist (drive-letter drive-letters) + (dolist (name names) + (dolist (dir directories) + (dolist (type types) + (let ((path (make-pathname + #+lispworks :host + #+lispworks (when drive-letter drive-letter) + #-lispworks :device + #-lispworks (when drive-letter drive-letter) + :name name + :type type + :directory + (etypecase dir + (pathname + (pathname-directory dir)) + (list + dir) + (string + (pathname-directory + (parse-namestring dir))))))) + (when (probe-file path) + (return-from find-foreign-library path))))))) + nil) + + +;; Copied directly from main source without MCL specializations +(defun default-foreign-library-type () + "Returns string naming default library type for platform" + #+(or win32 mswindows) "dll" + #-(or win32 mswindows) "so") \ No newline at end of file diff --git a/src/mcl/objects.cl b/src/mcl/objects.cl new file mode 100644 index 0000000..db4d536 --- /dev/null +++ b/src/mcl/objects.cl @@ -0,0 +1,113 @@ +;;;; -*- 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.6 2002/08/23 15:28:11 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and John DeSoi +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + + +;;; +;;; Some MCL specific utilities +;;; +(defun foreign-object-size (type) + "Returns the size for the specified mcl type or record type" + (let ((mcl-type (ccl:find-mactype type nil t))) + (if mcl-type + (ccl::mactype-record-size mcl-type) + (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)) ) ) ) ;error if not a record + + +; trap macros don't work right directly in the macros +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defun new-ptr (size) + (#_NewPtr size)) + +(defun dispose-ptr (ptr) + (#_DisposePtr ptr)) + +) + +;;; +;;; Start of standard UFFI +;;; +(defmacro allocate-foreign-object (type &optional (size :unspecified)) + "Allocates an instance of TYPE. If size is specified, then allocate +an array of TYPE with size SIZE." + (if (eq size :unspecified) + `(new-ptr ,(foreign-object-size (convert-from-uffi-type type :allocation))) + `(new-ptr ,(* size (foreign-object-size (convert-from-uffi-type type :allocation)))))) + + + +(defmacro free-foreign-object (obj) + `(dispose-ptr ,obj)) + +(defmacro null-pointer-p (obj) + `(ccl:%null-ptr-p ,obj)) + + +(defmacro make-null-pointer (type) + (declare (ignore type)) + `(ccl:%null-ptr)) + + +;! need to check uffi update and see if :routine is the right context + +(defun accessor-symbol (type get-or-set) + "Returns the symbol used to access the foreign type." + (let* ((mcl-type (convert-from-uffi-type (eval type) :routine)) + (mac-type (ccl:find-mactype mcl-type)) + name) + (ecase get-or-set + (:get (setf name (ccl::mactype-get-function mac-type))) + (:set (setf name (ccl::mactype-set-function mac-type)))) + (find-symbol (symbol-name name) :ccl))) + +(defmacro deref-pointer (ptr type) + `(,(accessor-symbol type :get) ,ptr)) + + +(defmacro deref-pointer-set (ptr type value) + `(,(accessor-symbol type :set) ,ptr ,value)) + + +(defsetf deref-pointer deref-pointer-set) + + +(defmacro pointer-address (obj) + `(ccl:%ptr-to-int ,obj)) + + +(defmacro with-foreign-objects (bindings &rest body) + (let ((simple nil) (recs nil) type) + (dolist (spec (reverse bindings)) ;keep order - macroexpands to let* + (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate)) + (if (ccl:mactype-p type) + (push (list (first spec) (foreign-object-size type)) simple) + (push spec recs))) + (cond ((and simple recs) + `(ccl:%stack-block ,simple + (ccl:rlet ,recs + ,@body))) + (simple `(ccl:%stack-block ,simple ,@body)) + (recs `(ccl:rlet ,recs ,@body))))) + + +(defmacro with-foreign-object ((var type) &rest body) + `(with-foreign-objects ((,var ,type)) ,@body)) diff --git a/src/mcl/package.cl b/src/mcl/package.cl new file mode 100644 index 0000000..b77e99a --- /dev/null +++ b/src/mcl/package.cl @@ -0,0 +1,71 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.cl +;;;; Purpose: Defines UFFI package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :cl-user) + +(defpackage :uffi + (:use :cl) + (:export + + ;; immediate types + #:def-constant + #:def-foreign-type + #:def-type + #:null-char-p + + ;; aggregate types + #:def-enum + #:def-struct + #:get-slot-value + #:get-slot-pointer + #:def-array-pointer + #:deref-array + #:def-union + + ;; objects + #:allocate-foreign-object + #:free-foreign-object + #:with-foreign-object + #:with-foreign-objects + #:pointer-address + #:deref-pointer + #:ensure-char-character + #:ensure-char-integer + #:null-pointer-p + #:make-null-pointer + #:+null-cstring-pointer+ + #:char-array-to-pointer + + ;; string functions + #:convert-from-cstring + #:convert-to-cstring + #:free-cstring + #:with-cstring + #:with-cstrings + #:convert-from-foreign-string + #:convert-to-foreign-string + #:allocate-foreign-string + #:with-foreign-string + + ;; function call + #:def-function + + ;; Libraries + #:load-foreign-library + + ;; Utilities + )) diff --git a/src/mcl/primitives.cl b/src/mcl/primitives.cl new file mode 100644 index 0000000..4dac954 --- /dev/null +++ b/src/mcl/primitives.cl @@ -0,0 +1,91 @@ +;;;; -*- 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.6 2002/08/23 15:28:11 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and John DeSoi +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + +; Wrapper for unexported function we have to use +(defmacro def-mcl-type (name type) + `(ccl::def-mactype (quote ,name) (ccl:find-mactype ,type))) + + +(defmacro def-constant (name value &key (export nil)) + "Macro to define a constant and to export it" + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant ,name ,value) + ,(if export (list 'export `(quote ,name)) (values)))) + +(defmacro def-type (name type) + "Generates a (deftype) statement for CL. Currently, only CMUCL +supports takes advantage of this optimization." + (declare (ignore type)) + `(deftype ,name () t)) + +(defmacro null-char-p (val) + "Returns T if character is NULL" + `(zerop ,val)) + + +(defmacro def-foreign-type (name type) + `(def-mcl-type ,name (convert-from-uffi-type ,type :type))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar +type-conversion-hash+ (make-hash-table :size 20))) + + +(defconstant +type-conversion-list+ + '((* . :pointer) (:void . :void) + (:short . :short) + (:pointer-void . :pointer) + (:cstring . :string) + (:char . :character) + (:unsigned-char . :unsigned-byte) + (:byte . :byte) + (:int . :integer) (:unsigned-int . :unsigned-integer) + (:long . :long) (:unsigned-long . :unsigned-long) + (:float . :single-float) (:double . :double-float) + (:array . :array))) + +(dolist (type +type-conversion-list+) + (setf (gethash (car type) +type-conversion-hash+) (cdr type))) + + +(defmethod ph (&optional (os *standard-output*)) + (maphash #'(lambda (k v) (format os "~&~S => ~S" k v)) +type-conversion-hash+)) + +(defun convert-from-uffi-type (type context) + "Converts from a uffi type to an implementation specific type" + (if (atom type) + (cond + #+mcl + ((and (eq type :void) (eq context :return)) nil) + (t + (let ((found-type (gethash type +type-conversion-hash+))) + (if found-type + found-type + type)))) + (cons (convert-from-uffi-type (first type) context) + (convert-from-uffi-type (rest type) context)))) + + + + + + diff --git a/src/mcl/strings.cl b/src/mcl/strings.cl new file mode 100644 index 0000000..ed311a2 --- /dev/null +++ b/src/mcl/strings.cl @@ -0,0 +1,198 @@ +;;;; -*- 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.5 2002/08/23 15:28:11 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and John DeSoi +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + + +(defvar +null-cstring-pointer+ (ccl:%null-ptr)) + +(defmacro convert-from-cstring (obj) + "Converts a string from a c-call. Same as convert-from-foreign-string, except +that CMU automatically converts strings from c-calls." + #+cmu obj + #+lispworks + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (fli:null-pointer-p ,stored) + nil + (fli:convert-from-foreign-string ,stored)))) + #+allegro + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (zerop ,stored) + nil + (values (excl:native-to-string ,stored))))) + #+mcl + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (ccl:%null-ptr-p ,stored) + nil + (values (ccl:%get-cstring ,stored))))) + + + ) + +(defmacro convert-to-cstring (obj) + #+lispworks + `(if (null ,obj) + +null-cstring-pointer+ + (fli:convert-to-foreign-string ,obj)) + #+allegro + `(if (null ,obj) + 0 + (values (excl:string-to-native ,obj))) + #+cmu + (declare (ignore obj)) + #+mcl + `(if (null ,obj) + +null-cstring-pointer+ + (let ((ptr (new-ptr (1+ (length ,obj))))) + (ccl:%put-cstring ptr ,obj) + ptr)) + ) + +(defmacro free-cstring (obj) + #+lispworks + `(unless (fli:null-pointer-p ,obj) + (fli:free-foreign-object ,obj)) + #+allegro + `(unless (zerop obj) + (ff:free-fobject ,obj)) + #+cmu + (declare (ignore obj)) + #+mcl + `(unless (ccl:%null-ptr-p ,obj) + (dispose-ptr ,obj)) + + ) + +;; Either length or null-terminated-p must be non-nil +(defmacro convert-from-foreign-string (obj &key + length + (null-terminated-p t)) + #+allegro + `(if (zerop ,obj) + nil + (values (excl:native-to-string + ,obj + ,@(if length (list :length length) (values)) + :truncate (not ,null-terminated-p)))) + #+lispworks + `(if (fli:null-pointer-p ,obj) + nil + (fli:convert-from-foreign-string + ,obj + ,@(if length (list :length length) (values)) + :null-terminated-p ,null-terminated-p + :external-format '(:latin-1 :eol-style :lf))) + #+cmu + `(cmucl-naturalize-cstring (alien:alien-sap ,obj) + :length ,length + :null-terminated-p ,null-terminated-p) + #+mcl + (declare (ignore null-terminated-p)) + #+mcl + `(if (ccl:%null-ptr-p ,obj) + nil + (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil))) + ) + +(defmacro convert-to-foreign-string (obj) + #+lispworks + `(if (null ,obj) + +null-cstring-pointer+ + (fli:convert-to-foreign-string ,obj)) + #+allegro + `(if (null ,obj) + 0 + (values (excl:string-to-native ,obj))) + #+cmu + (let ((size (gensym)) + (storage (gensym)) + (i (gensym))) + `(when (stringp ,obj) + (let* ((,size (length ,obj)) + (,storage (alien:make-alien char (1+ ,size)))) + (setq ,storage (alien:cast ,storage (* char))) + (dotimes (,i ,size) + (declare (fixnum ,i) + (optimize (speed 3) (safety 0))) + (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i)))) + (setf (alien:deref ,storage ,size) 0) + ,storage))) + #+mcl + `(if (null ,obj) + +null-cstring-pointer+ + (let ((ptr (new-ptr (1+ (length ,obj))))) + (ccl:%put-cstring ptr ,obj) + ptr)) + ) + + +(defmacro allocate-foreign-string (size &key (unsigned t)) + #+cmu + (let ((array-def (gensym))) + `(let ((,array-def (list 'alien:array 'c-call:char ,size))) + (eval `(alien:cast (alien:make-alien ,,array-def) + ,(if ,unsigned + '(* (alien:unsigned 8)) + '(* (alien:signed 8))))))) + #+lispworks + `(fli:allocate-foreign-object :type + ,(if unsigned + ''(:unsigned :char) + :char) + :nelems ,size) + #+allegro + (declare (ignore unsigned)) + #+allegro + `(ff:allocate-fobject :char :c ,size) + #+mcl + (declare (ignore unsigned)) + #+mcl + `(new-ptr ,size) + + ) + + +; I'm sure there must be a better way to write this... +(defmacro with-cstring ((foreign-string lisp-string) &body body) + `(if (stringp ,lisp-string) + (ccl:with-cstrs ((,foreign-string ,lisp-string)) + ,@body) + (let ((,foreign-string +null-cstring-pointer+)) + ,@body))) + + +#| Works but, supposedly the built in method is better +(defmacro with-cstring ((foreign-string lisp-string) &body body) + (let ((result (gensym))) + `(let* ((,foreign-string (convert-to-cstring ,lisp-string)) + (,result ,@body)) + (dispose-ptr ,foreign-string) + ,result)) + ) + +|# + + + + + diff --git a/src/objects.cl b/src/objects.cl new file mode 100644 index 0000000..7cd3cb1 --- /dev/null +++ b/src/objects.cl @@ -0,0 +1,144 @@ +;;;; -*- 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.22 2002/08/23 15:28:52 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/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..c107664 --- /dev/null +++ b/src/primitives.cl @@ -0,0 +1,198 @@ +;;;; -*- 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.22 2002/08/23 15:28:52 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + +(defmacro def-constant (name value &key (export nil)) + "Macro to define a constant and to export it" + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant ,name ,value) + ,(when export (list 'export `(quote ,name))) + ',name)) + +(defmacro def-type (name type) + "Generates a (deftype) statement for CL. Currently, only CMUCL +supports takes advantage of this optimization." + #+(or lispworks allegro) + (declare (ignore type)) + #+(or lispworks allegro) + `(deftype ,name () t) + #+cmu + `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare))) + #+sbcl + `(deftype ,name () '(sb-alien:alien ,(convert-from-uffi-type type :declare))) + ) + +(defmacro null-char-p (val) + "Returns T if character is NULL" + `(zerop ,val)) + +(defmacro def-foreign-type (name type) + #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type)) + #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type)) + #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type)) + #+sbcl `(sb-alien:def-alien-type ,name ,(convert-from-uffi-type type :type)) + ) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar +type-conversion-hash+ (make-hash-table :size 20)) + #+(or cmu sbcl) (defvar +cmu-def-type-hash+ (make-hash-table :size 20)) + ) + +#+cmu +(defconstant +cmu-def-type-list+ + '((:char . (alien:signed 8)) + (:unsigned-char . (alien:unsigned 8)) + (:byte . (alien:signed 8)) + (:unsigned-byte . (alien:unsigned 8)) + (:short . (alien:signed 16)) + (:unsigned-short . (alien:unsigned 16)) + (:int . (alien:signed 32)) + (:unsigned-int . (alien:unsigned 32)) + (:long . (alien:signed 32)) + (:unsigned-long . (alien:unsigned 32)) + (:float . alien:single-float) + (:double . alien:double-float) + ) + "Conversions in CMUCL for def-foreign-type are different than in def-function") +#+sbcl +(defconstant +cmu-def-type-list+ + '((:char . (sb-alien:signed 8)) + (:unsigned-char . (sb-alien:unsigned 8)) + (:byte . (sb-alien:signed 8)) + (:unsigned-byte . (sb-alien:unsigned 8)) + (:short . (sb-alien:signed 16)) + (:unsigned-short . (sb-alien:unsigned 16)) + (:int . (sb-alien:signed 32)) + (:unsigned-int . (sb-alien:unsigned 32)) + (:long . (sb-alien:signed 32)) + (:unsigned-long . (sb-alien:unsigned 32)) + (:float . sb-alien:single-float) + (:double . sb-alien:double-float) + ) + "Conversions in SBCL for def-foreign-type are different than in def-function") + +(defparameter +type-conversion-list+ nil) + +#+cmu +(setq +type-conversion-list+ + '((* . *) (:void . c-call:void) + (:short . c-call:short) + (:pointer-void . (* t)) + (:cstring . c-call:c-string) + (:char . c-call:char) + (:unsigned-char . (alien:unsigned 8)) + (:byte . (alien:signed 8)) + (:unsigned-byte . (alien:unsigned 8)) + (:short . c-call:unsigned-short) + (:unsigned-short . c-call:unsigned-short) + (:int . alien:integer) (:unsigned-int . c-call:unsigned-int) + (:long . c-call:long) (:unsigned-long . c-call:unsigned-long) + (:float . c-call:float) (:double . c-call:double) + (:array . alien:array))) + +#+sbcl +(setq +type-conversion-list+ + '((* . *) (:void . void) + (:short . short) + (:pointer-void . (* t)) + (:cstring . c-string) + (:char . char) + (:unsigned-char . (sb-alien:unsigned 8)) + (:byte . (sb-alien:signed 8)) + (:unsigned-byte . (sb-alien:unsigned 8)) + (:short . unsigned-short) + (:unsigned-short . unsigned-short) + (:int . integer) (:unsigned-int . unsigned-int) + (:long . long) (:unsigned-long . unsigned-long) + (:float . float) (:double . double) + (:array . array))) + +#+allegro +(setq +type-conversion-list+ + '((* . *) (:void . :void) + (:short . :short) + (:pointer-void . (* :void)) + (:cstring . (* :unsigned-char)) + (:byte . :char) + (:unsigned-byte . :unsigned-byte) + (:char . :char) + (:unsigned-char . :unsigned-char) + (:int . :int) (:unsigned-int . :unsigned-int) + (:long . :long) (:unsigned-long . :unsigned-long) + (:float . :float) (:double . :double) + (:array . :array))) +#+lispworks +(setq +type-conversion-list+ + '((* . :pointer) (:void . :void) + (:short . :short) + (:pointer-void . (:pointer :void)) + (:cstring . (:reference-pass (:ef-mb-string :external-format :latin-1) + :allow-null t)) + (:cstring-returning . (:reference (:ef-mb-string :external-format :latin-1) :allow-null t)) + (:byte . :byte) + (:unsigned-byte . (:unsigned :byte)) + (:char . :char) + (:unsigned-char . (:unsigned :char)) + (:int . :int) (:unsigned-int . (:unsigned :int)) + (:long . :long) (:unsigned-long . (:unsigned :long)) + (:float . :float) (:double . :double) + (:array . :c-array))) + +(dolist (type +type-conversion-list+) + (setf (gethash (car type) +type-conversion-hash+) (cdr type))) + +#+(or cmu sbcl) +(dolist (type +cmu-def-type-list+) + (setf (gethash (car type) +cmu-def-type-hash+) (cdr type))) + +(defun basic-convert-from-uffi-type (type) + (let ((found-type (gethash type +type-conversion-hash+))) + (if found-type + found-type + type))) + +(defun convert-from-uffi-type (type context) + "Converts from a uffi type to an implementation specific type" + (if (atom type) + (cond + #+allegro + ((and (or (eq context :routine) (eq context :return)) + (eq type :cstring)) + (setq type '((* :char) integer))) + #+(or cmu sbcl) + ((eq context :type) + (let ((cmu-type (gethash type +cmu-def-type-hash+))) + (if cmu-type + cmu-type + (basic-convert-from-uffi-type type)))) + #+lispworks + ((and (eq context :return) + (eq type :cstring)) + (basic-convert-from-uffi-type :cstring-returning)) + (t + (basic-convert-from-uffi-type type))) + (cons (convert-from-uffi-type (first type) context) + (convert-from-uffi-type (rest type) context)))) + + + + + + diff --git a/src/strings.cl b/src/strings.cl new file mode 100644 index 0000000..39c8572 --- /dev/null +++ b/src/strings.cl @@ -0,0 +1,193 @@ +;;;; -*- 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.20 2002/08/23 15:28:52 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :uffi) + + +(def-constant +null-cstring-pointer+ + #+cmu nil + #+allegro 0 + #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char)) + #-(or cmu allegro lispworks) nil +) + +(defmacro convert-from-cstring (obj) + "Converts a string from a c-call. Same as convert-from-foreign-string, except +that LW/CMU automatically converts strings from c-calls." + #+cmu obj + #+lispworks obj + #+allegro + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (zerop ,stored) + nil + (values (excl:native-to-string ,stored))))) + ) + +(defmacro convert-to-cstring (obj) + #+cmu obj + #+lispworks obj + #+allegro + `(if (null ,obj) + 0 + (values (excl:string-to-native ,obj))) + ) + +(defmacro free-cstring (obj) + #+cmu (declare (ignore obj)) + #+lispworks (declare (ignore obj)) + #+allegro + `(unless (zerop obj) + (ff:free-fobject ,obj)) + ) + +(defmacro with-cstring ((cstring lisp-string) &body body) + #+cmu + `(let ((,cstring ,lisp-string)) ,@body) + #+lispworks + `(let ((,cstring ,lisp-string)) ,@body) + #+allegro + (let ((acl-native (gensym))) + `(excl:with-native-string (,acl-native ,lisp-string) + (let ((,cstring (if ,lisp-string ,acl-native 0))) + ,@body))) + ) + +(defmacro with-cstrings (bindings &rest body) + (if bindings + `(with-cstring ,(car bindings) + (with-cstrings ,(cdr bindings) + ,@body)) + `(progn ,@body))) + +;;; Foreign string functions + +(defmacro convert-to-foreign-string (obj) + #+lispworks + `(if (null ,obj) + +null-cstring-pointer+ + (fli:convert-to-foreign-string ,obj)) + #+allegro + `(if (null ,obj) + 0 + (values (excl:string-to-native ,obj))) + #+cmu + (let ((size (gensym)) + (storage (gensym)) + (i (gensym))) + `(etypecase ,obj + (null + (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8)))) + (string + (let* ((,size (length ,obj)) + (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size)))) + (setq ,storage (alien:cast ,storage (* (alien:unsigned 8)))) + (locally + (declare (optimize (speed 3) (safety 0))) + (dotimes (,i ,size) + (declare (fixnum ,i)) + (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i)))) + (setf (alien:deref ,storage ,size) 0)) + ,storage)))) + ) + + +;; Either length or null-terminated-p must be non-nil +(defmacro convert-from-foreign-string (obj &key + length + (null-terminated-p t)) + #+allegro + `(if (zerop ,obj) + nil + (values (excl:native-to-string + ,obj + ,@(if length (list :length length) (values)) + :truncate (not ,null-terminated-p)))) + #+lispworks + `(if (fli:null-pointer-p ,obj) + nil + (fli:convert-from-foreign-string + ,obj + ,@(if length (list :length length) (values)) + :null-terminated-p ,null-terminated-p + :external-format '(:latin-1 :eol-style :lf))) + #+cmu + `(if (null-pointer-p ,obj) + nil + (cmucl-naturalize-cstring (alien:alien-sap ,obj) + :length ,length + :null-terminated-p ,null-terminated-p)) + ) + + + +(defmacro allocate-foreign-string (size &key (unsigned t)) + #+cmu + (let ((array-def (gensym))) + `(let ((,array-def (list 'alien:array 'c-call:char ,size))) + (eval `(alien:cast (alien:make-alien ,,array-def) + ,(if ,unsigned + '(* (alien:unsigned 8)) + '(* (alien:signed 8))))))) + #+lispworks + `(fli:allocate-foreign-object :type + ,(if unsigned + ''(:unsigned :char) + :char) + :nelems ,size) + #+allegro + (declare (ignore unsigned)) + #+allegro + `(ff:allocate-fobject :char :c ,size) + ) + +(defmacro with-foreign-string ((foreign-string lisp-string) &body body) + (let ((result (gensym))) + `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string)) + (,result (progn ,@body))) + (declare (dynamic-extent ,foreign-string)) + (free-foreign-object ,foreign-string) + ,result))) + + +;; Modified from CMUCL's source to handle non-null terminated strings +#+cmu +(defun cmucl-naturalize-cstring (sap &key + length + (null-terminated-p t)) + (declare (type system:system-area-pointer sap)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let ((null-terminated-length + (when null-terminated-p + (loop + for offset of-type fixnum upfrom 0 + until (zerop (system:sap-ref-8 sap offset)) + finally (return offset))))) + (if length + (if (and null-terminated-length + (> (the fixnum length) (the fixnum null-terminated-length))) + (setq length null-terminated-length)) + (setq length null-terminated-length))) + (let ((result (make-string length))) + (kernel:copy-from-system-area sap 0 + result (* vm:vector-data-offset + vm:word-bits) + (* length vm:byte-bits)) + result))) diff --git a/uffi.system b/uffi.system index 545fd47..12483e0 100644 --- a/uffi.system +++ b/uffi.system @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: uffi.system,v 1.15 2002/07/26 03:18:27 kevin Exp $ +;;;; $Id: uffi.system,v 1.16 2002/08/23 15:29:06 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -19,17 +19,36 @@ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :make) -;; For use with non-Debian installations +;;; UFFI system definition (for Common Lisp Controller systems) + +#+common-lisp-controller +(make:defsystem :uffi + :source-pathname #-mcl "cl-library:uffi;" + #+mcl "cl-library:uffi;mcl;" + :source-extension "cl" + :components + ((:file "package") + (:file "primitives" :depends-on ("package")) + (:file "strings" :depends-on ("primitives")) + (:file "objects" :depends-on ("primitives")) + (:file "aggregates" :depends-on ("primitives")) + (:file "functions" :depends-on ("primitives")) + (:file "libraries" :depends-on ("package"))) + :finally-do + (pushnew :uffi cl:*features*)) + +;; For use with non-Common Lisp Controller installations + +#-common-lisp-controller (let ((helper-pathname (make-pathname :name "set-cl-library" :type "cl" :defaults *load-truename*))) (when (probe-file helper-pathname) (load helper-pathname))) -;;; UFFI system definition - +#-common-lisp-controller (make:defsystem :uffi - :source-pathname #-mcl "cl-library:uffi;" - #+mcl "cl-library:uffi;mcl;" + :source-pathname #-mcl "cl-library:uffi;src;" + #+mcl "cl-library:uffi;src;mcl;" :source-extension "cl" :components ((:file "package") diff --git a/uffi/.cvsignore b/uffi/.cvsignore deleted file mode 100755 index ca8d09f..0000000 --- a/uffi/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -.bin diff --git a/uffi/Makefile b/uffi/Makefile deleted file mode 100644 index 0dbea7d..0000000 --- a/uffi/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -SUBDIRS := mcl - -include ../Makefile.common - -.PHONY: distclean -distclean: clean diff --git a/uffi/aggregates.cl b/uffi/aggregates.cl deleted file mode 100644 index 098947e..0000000 --- a/uffi/aggregates.cl +++ /dev/null @@ -1,125 +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.1 2002/08/02 14:39:12 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - -(defmacro def-enum (enum-name args &key (separator-string "#")) - "Creates a constants for a C type enum list, symbols are created -in the created in the current package. The symbol is the concatenation -of the enum-name name, separator-string, and field-name" - (let ((counter 0) - (cmds nil) - (constants nil)) - (declare (fixnum counter)) - (dolist (arg args) - (let ((name (if (listp arg) (car arg) arg)) - (value (if (listp arg) - (prog1 - (setq counter (cadr arg)) - (incf counter)) - (prog1 - counter - (incf counter))))) - (setq name (intern (concatenate 'string - (symbol-name enum-name) - separator-string - (symbol-name name)))) - (push `(uffi:def-constant ,name ,value) constants))) - (setf cmds (append '(progn) - #+allegro `((ff:def-foreign-type ,enum-name :int)) - #+lispworks `((fli:define-c-typedef ,enum-name :int)) - #+cmu `((alien:def-alien-type ,enum-name alien:signed)) - (nreverse constants))) - cmds)) - - -(defmacro def-array-pointer (name-array type) - #+allegro - `(ff:def-foreign-type ,name-array - (:array ,(convert-from-uffi-type type :array))) - #+lispworks - `(fli:define-c-typedef ,name-array - (:c-array ,(convert-from-uffi-type type :array))) - #+cmu - `(alien:def-alien-type ,name-array - (* ,(convert-from-uffi-type type :array))) - ) - -(defun process-struct-fields (name fields) - (let (processed) - (dolist (field fields) - (let ((field-name (car field)) - (type (cadr field))) - (push (append (list field-name) - (if (eq type :pointer-self) - #+cmu `((* (alien:struct ,name))) - #-cmu `((* ,name)) - `(,(convert-from-uffi-type type :struct)))) - processed))) - (nreverse processed))) - - -(defmacro def-struct (name &rest fields) - #+cmu - `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields))) - #+allegro - `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields))) - #+lispworks - `(fli:define-c-struct ,name ,@(process-struct-fields name fields)) - ) - - -(defmacro get-slot-value (obj type slot) - #+(or lispworks cmu) (declare (ignore type)) - #+allegro - `(ff:fslot-value-typed ,type :c ,obj ,slot) - #+lispworks - `(fli:foreign-slot-value ,obj ,slot) - #+cmu - `(alien:slot ,obj ,slot) - ) - -(defmacro get-slot-pointer (obj type slot) - #+(or lispworks cmu) (declare (ignore type)) - #+allegro - `(ff:fslot-value-typed ,type :c ,obj ,slot) - #+lispworks - `(fli:foreign-slot-pointer ,obj ,slot) - #+cmu - `(alien:slot ,obj ,slot) - ) - -(defmacro deref-array (obj type i) - "Returns a field from a row" - #+(or lispworks cmu) (declare (ignore type)) - #+cmu `(alien:deref ,obj ,i) - #+lispworks `(fli:dereference ,obj :index ,i) - #+allegro `(ff:fslot-value-typed ,type :c ,obj ,i) - ) - -(defmacro def-union (name &rest fields) - #+allegro - `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields))) - #+lispworks - `(fli:define-c-union ,name ,@(process-struct-fields name fields)) - #+cmu - `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields))) -) - - diff --git a/uffi/corman/corman-uffi.cl b/uffi/corman/corman-uffi.cl deleted file mode 100644 index 759ff61..0000000 --- a/uffi/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/08/02 14:39:12 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/uffi/functions.cl b/uffi/functions.cl deleted file mode 100644 index 2396340..0000000 --- a/uffi/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/08/02 14:39:12 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/uffi/libraries.cl b/uffi/libraries.cl deleted file mode 100644 index 4896a15..0000000 --- a/uffi/libraries.cl +++ /dev/null @@ -1,107 +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.1 2002/08/02 14:39:12 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - -(defvar *loaded-libraries* nil - "List of foreign libraries loaded. Used to prevent reloading a library") - -(defun default-foreign-library-type () - "Returns string naming default library type for platform" - #+(or win32 mswindows) "dll" - #-(or win32 mswindows) "so") - -(defun find-foreign-library (names directories &key types drive-letters) - "Looks for a foreign library. directories can be a single -string or a list of strings of candidate directories. Use default -library type if type is not specified." - (unless types - (setq types (default-foreign-library-type))) - (unless (listp types) - (setq types (list types))) - (unless (listp names) - (setq names (list names))) - (unless (listp directories) - (setq directories (list directories))) - #+(or win32 mswindows) - (unless (listp drive-letters) - (setq drive-letters (list drive-letters))) - #-(or win32 mswindows) - (setq drive-letters '(nil)) - (dolist (drive-letter drive-letters) - (dolist (name names) - (dolist (dir directories) - (dolist (type types) - (let ((path (make-pathname - #+lispworks :host - #+lispworks (when drive-letter drive-letter) - #-lispworks :device - #-lispworks (when drive-letter drive-letter) - :name name - :type type - :directory - (etypecase dir - (pathname - (pathname-directory dir)) - (list - dir) - (string - (pathname-directory - (parse-namestring dir))))))) - (when (probe-file path) - (return-from find-foreign-library path))))))) - nil) - - -(defun load-foreign-library (filename &key module supporting-libraries - force-load) - #+allegro (declare (ignore module supporting-libraries)) - #+lispworks (declare (ignore supporting-libraries)) - #+cmu (declare (ignore module)) - - (when (and filename (probe-file filename)) - (if (pathnamep filename) ;; ensure filename is a string to check if - (setq filename (namestring filename))) ; already loaded - - (if (and (not force-load) - (find filename *loaded-libraries* :test #'string-equal)) - t ;; return T, but don't reload library - (progn - #+cmu - (let ((type (pathname-type (parse-namestring filename)))) - (if (equal type "so") - (sys::load-object-file filename) - (alien:load-foreign filename - :libraries - (convert-supporting-libraries-to-string - supporting-libraries)))) - - #+lispworks (fli:register-module module - :real-name filename) - #+allegro (load filename) - - (push filename *loaded-libraries*) - t))) - ) - -(defun convert-supporting-libraries-to-string (libs) - (let (lib-load-list) - (dolist (lib libs) - (push (format nil "-l~A" lib) lib-load-list)) - (nreverse lib-load-list))) diff --git a/uffi/mcl/Makefile b/uffi/mcl/Makefile deleted file mode 100644 index ce6118b..0000000 --- a/uffi/mcl/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -SUBDIRS := - -include ../../Makefile.common - -.PHONY: distclean -distclean: clean diff --git a/uffi/mcl/aggregates.cl b/uffi/mcl/aggregates.cl deleted file mode 100644 index 3162140..0000000 --- a/uffi/mcl/aggregates.cl +++ /dev/null @@ -1,122 +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.1 2002/08/02 14:39:12 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and John DeSoi -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - - - -(defmacro def-enum (enum-name args &key (separator-string "#")) - "Creates a constants for a C type enum list, symbols are created -in the created in the current package. The symbol is the concatenation -of the enum-name name, separator-string, and field-name" - (let ((counter 0) - (cmds nil) - (constants nil)) - (declare (fixnum counter)) - (dolist (arg args) - (let ((name (if (listp arg) (car arg) arg)) - (value (if (listp arg) - (prog1 - (setq counter (cadr arg)) - (incf counter)) - (prog1 - counter - (incf counter))))) - (setq name (intern (concatenate 'string - (symbol-name enum-name) - separator-string - (symbol-name name)))) - (push `(uffi:def-constant ,name ,value) constants))) - (setf cmds (append '(progn) - #+allegro `((ff:def-foreign-type ,enum-name :int)) - #+lispworks `((fli:define-c-typedef ,enum-name :int)) - #+cmu `((alien:def-alien-type ,enum-name alien:signed)) - #+mcl `((def-mcl-type ,enum-name :integer)) - (nreverse constants))) - cmds)) - - - -(defmacro def-array-pointer (name-array type) - `(def-mcl-type ,name-array '(:array ,type))) - - -; this is how rref expands array slot access (minus adding the struct offset) -(defmacro deref-array (obj type i) - "Returns a field from a row" - `(,(accessor-symbol type :get) ,obj (* (the fixnum ,i) ,(foreign-object-size type)))) - -(defmacro deref-array-set (obj type i value) - `(,(accessor-symbol type :set) ,obj ,value (* (the fixnum ,i) ,(foreign-object-size type)))) - -(defsetf deref-array deref-array-set) - - -(defun process-struct-fields (name fields variant) - (let (processed) - (dolist (field fields) - (let* ((field-name (car field)) - (type (cadr field)) - (def (append (list field-name) - (if (eq type :pointer-self) - #+cmu `((* (alien:struct ,name))) - #-cmu `((* ,name)) - `(,(convert-from-uffi-type type :struct)))))) - (if variant - (push (list def) processed) - (push def processed)))) - (nreverse processed))) - - -(defmacro def-struct (name &rest fields) - `(ccl:defrecord ,name ,@(process-struct-fields name fields nil))) - - -(defmacro def-union (name &rest fields) - `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))) - - -; Assuming everything is pointer based - no support for Mac handles -(defmacro get-slot-value (obj type slot) ;use setf to set values - `(ccl:pref ,obj ,(read-from-string (format nil "~a.~a" type slot)))) - - -(defmacro get-slot-pointer (obj type slot) - `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))) - - - -#| a few simple tests -(def-union union - (l1 :long) - (s1 :short)) - -(def-struct struct - (s1 :short) - (l1 :long) - (u1 :union)) - -(defvar s (allocate-foreign-object :struct)) -(setf (get-slot-value s :struct :s1) 3) -(get-slot-value s :struct :s1) -(setf (get-slot-value s :struct :u1.s1) 5) -(get-slot-value s :struct :u1.s1) - -|# \ No newline at end of file diff --git a/uffi/mcl/functions.cl b/uffi/mcl/functions.cl deleted file mode 100644 index 421ae61..0000000 --- a/uffi/mcl/functions.cl +++ /dev/null @@ -1,70 +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.1 2002/08/02 14:39:12 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and John DeSoi -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - -(defun process-function-args (args) - (if (null args) - #+lispworks nil - #+allegro '(:void) - #+cmu nil - #+mcl nil - (let (processed) - (dolist (arg args) - (push (process-one-function-arg arg) processed)) - (nreverse processed)))) - -(defun process-one-function-arg (arg) - (let ((name (car arg)) - (type (convert-from-uffi-type (cadr arg) :routine))) - (if (and (listp type) (listp (car type))) - (append (list name) type) - (list name type)) - )) - -(defun allegro-convert-return-type (type) - (if (and (listp type) (not (listp (car type)))) - (list type) - type)) - -;; name is either a string representing foreign name, or a list -;; of foreign-name as a string and lisp name as a symbol - - -(defmacro def-function (names args &key module returning) - (declare (ignore module)) - - (let* ((result-type (convert-from-uffi-type returning :return)) - (function-args (process-function-args args)) - (foreign-name (if (atom names) names (car names))) - (lisp-name (if (atom names) (make-lisp-name names) (cadr names)))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (ccl:define-entry-point (,lisp-name ,foreign-name) - ,function-args - ,result-type)))) - - -(defun make-lisp-name (name) - (let ((converted (substitute #\- #\_ name))) - (intern - #+case-sensitive converted - #-case-sensitive (string-upcase converted)))) - - diff --git a/uffi/mcl/libraries.cl b/uffi/mcl/libraries.cl deleted file mode 100644 index ae78b6a..0000000 --- a/uffi/mcl/libraries.cl +++ /dev/null @@ -1,80 +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.1 2002/08/02 14:39:12 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and John DeSoi -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - -(defvar *loaded-libraries* nil - "List of foreign libraries loaded. Used to prevent reloading a library") - -;in MCL calling this more than once for the same library does not do anything -(defmacro load-foreign-library (filename &key module supporting-libraries) - (declare (ignore module supporting-libraries)) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (when (ccl:add-to-shared-library-search-path ,filename t) - (pushnew ,filename *loaded-libraries*)))) - -;; Copied directly from main source without MCL specializations -(defun find-foreign-library (names directories &key types drive-letters) - "Looks for a foreign library. directories can be a single -string or a list of strings of candidate directories. Use default -library type if type is not specified." - (unless types - (setq types (default-foreign-library-type))) - (unless (listp types) - (setq types (list types))) - (unless (listp names) - (setq names (list names))) - (unless (listp directories) - (setq directories (list directories))) - #+(or win32 mswindows) - (unless (listp drive-letters) - (setq drive-letters (list drive-letters))) - #-(or win32 mswindows) - (setq drive-letters '(nil)) - (dolist (drive-letter drive-letters) - (dolist (name names) - (dolist (dir directories) - (dolist (type types) - (let ((path (make-pathname - #+lispworks :host - #+lispworks (when drive-letter drive-letter) - #-lispworks :device - #-lispworks (when drive-letter drive-letter) - :name name - :type type - :directory - (etypecase dir - (pathname - (pathname-directory dir)) - (list - dir) - (string - (pathname-directory - (parse-namestring dir))))))) - (when (probe-file path) - (return-from find-foreign-library path))))))) - nil) - - -;; Copied directly from main source without MCL specializations -(defun default-foreign-library-type () - "Returns string naming default library type for platform" - #+(or win32 mswindows) "dll" - #-(or win32 mswindows) "so") \ No newline at end of file diff --git a/uffi/mcl/objects.cl b/uffi/mcl/objects.cl deleted file mode 100644 index f959dc1..0000000 --- a/uffi/mcl/objects.cl +++ /dev/null @@ -1,113 +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.1 2002/08/02 14:39:12 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and John DeSoi -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - - -;;; -;;; Some MCL specific utilities -;;; -(defun foreign-object-size (type) - "Returns the size for the specified mcl type or record type" - (let ((mcl-type (ccl:find-mactype type nil t))) - (if mcl-type - (ccl::mactype-record-size mcl-type) - (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)) ) ) ) ;error if not a record - - -; trap macros don't work right directly in the macros -(eval-when (:compile-toplevel :load-toplevel :execute) - -(defun new-ptr (size) - (#_NewPtr size)) - -(defun dispose-ptr (ptr) - (#_DisposePtr ptr)) - -) - -;;; -;;; Start of standard UFFI -;;; -(defmacro allocate-foreign-object (type &optional (size :unspecified)) - "Allocates an instance of TYPE. If size is specified, then allocate -an array of TYPE with size SIZE." - (if (eq size :unspecified) - `(new-ptr ,(foreign-object-size (convert-from-uffi-type type :allocation))) - `(new-ptr ,(* size (foreign-object-size (convert-from-uffi-type type :allocation)))))) - - - -(defmacro free-foreign-object (obj) - `(dispose-ptr ,obj)) - -(defmacro null-pointer-p (obj) - `(ccl:%null-ptr-p ,obj)) - - -(defmacro make-null-pointer (type) - (declare (ignore type)) - `(ccl:%null-ptr)) - - -;! need to check uffi update and see if :routine is the right context - -(defun accessor-symbol (type get-or-set) - "Returns the symbol used to access the foreign type." - (let* ((mcl-type (convert-from-uffi-type (eval type) :routine)) - (mac-type (ccl:find-mactype mcl-type)) - name) - (ecase get-or-set - (:get (setf name (ccl::mactype-get-function mac-type))) - (:set (setf name (ccl::mactype-set-function mac-type)))) - (find-symbol (symbol-name name) :ccl))) - -(defmacro deref-pointer (ptr type) - `(,(accessor-symbol type :get) ,ptr)) - - -(defmacro deref-pointer-set (ptr type value) - `(,(accessor-symbol type :set) ,ptr ,value)) - - -(defsetf deref-pointer deref-pointer-set) - - -(defmacro pointer-address (obj) - `(ccl:%ptr-to-int ,obj)) - - -(defmacro with-foreign-objects (bindings &rest body) - (let ((simple nil) (recs nil) type) - (dolist (spec (reverse bindings)) ;keep order - macroexpands to let* - (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate)) - (if (ccl:mactype-p type) - (push (list (first spec) (foreign-object-size type)) simple) - (push spec recs))) - (cond ((and simple recs) - `(ccl:%stack-block ,simple - (ccl:rlet ,recs - ,@body))) - (simple `(ccl:%stack-block ,simple ,@body)) - (recs `(ccl:rlet ,recs ,@body))))) - - -(defmacro with-foreign-object ((var type) &rest body) - `(with-foreign-objects ((,var ,type)) ,@body)) diff --git a/uffi/mcl/package.cl b/uffi/mcl/package.cl deleted file mode 100644 index b77e99a..0000000 --- a/uffi/mcl/package.cl +++ /dev/null @@ -1,71 +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 - #:pointer-address - #:deref-pointer - #:ensure-char-character - #:ensure-char-integer - #:null-pointer-p - #:make-null-pointer - #:+null-cstring-pointer+ - #:char-array-to-pointer - - ;; string functions - #:convert-from-cstring - #:convert-to-cstring - #:free-cstring - #:with-cstring - #:with-cstrings - #:convert-from-foreign-string - #:convert-to-foreign-string - #:allocate-foreign-string - #:with-foreign-string - - ;; function call - #:def-function - - ;; Libraries - #:load-foreign-library - - ;; Utilities - )) diff --git a/uffi/mcl/primitives.cl b/uffi/mcl/primitives.cl deleted file mode 100644 index f48b2a2..0000000 --- a/uffi/mcl/primitives.cl +++ /dev/null @@ -1,91 +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.1 2002/08/02 14:39:12 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and John DeSoi -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - -; Wrapper for unexported function we have to use -(defmacro def-mcl-type (name type) - `(ccl::def-mactype (quote ,name) (ccl:find-mactype ,type))) - - -(defmacro def-constant (name value &key (export nil)) - "Macro to define a constant and to export it" - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant ,name ,value) - ,(if export (list 'export `(quote ,name)) (values)))) - -(defmacro def-type (name type) - "Generates a (deftype) statement for CL. Currently, only CMUCL -supports takes advantage of this optimization." - (declare (ignore type)) - `(deftype ,name () t)) - -(defmacro null-char-p (val) - "Returns T if character is NULL" - `(zerop ,val)) - - -(defmacro def-foreign-type (name type) - `(def-mcl-type ,name (convert-from-uffi-type ,type :type))) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar +type-conversion-hash+ (make-hash-table :size 20))) - - -(defconstant +type-conversion-list+ - '((* . :pointer) (:void . :void) - (:short . :short) - (:pointer-void . :pointer) - (:cstring . :string) - (:char . :character) - (:unsigned-char . :unsigned-byte) - (:byte . :byte) - (:int . :integer) (:unsigned-int . :unsigned-integer) - (:long . :long) (:unsigned-long . :unsigned-long) - (:float . :single-float) (:double . :double-float) - (:array . :array))) - -(dolist (type +type-conversion-list+) - (setf (gethash (car type) +type-conversion-hash+) (cdr type))) - - -(defmethod ph (&optional (os *standard-output*)) - (maphash #'(lambda (k v) (format os "~&~S => ~S" k v)) +type-conversion-hash+)) - -(defun convert-from-uffi-type (type context) - "Converts from a uffi type to an implementation specific type" - (if (atom type) - (cond - #+mcl - ((and (eq type :void) (eq context :return)) nil) - (t - (let ((found-type (gethash type +type-conversion-hash+))) - (if found-type - found-type - type)))) - (cons (convert-from-uffi-type (first type) context) - (convert-from-uffi-type (rest type) context)))) - - - - - - diff --git a/uffi/mcl/strings.cl b/uffi/mcl/strings.cl deleted file mode 100644 index 7f7476a..0000000 --- a/uffi/mcl/strings.cl +++ /dev/null @@ -1,198 +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.1 2002/08/02 14:39:12 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and John DeSoi -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - - -(defvar +null-cstring-pointer+ (ccl:%null-ptr)) - -(defmacro convert-from-cstring (obj) - "Converts a string from a c-call. Same as convert-from-foreign-string, except -that CMU automatically converts strings from c-calls." - #+cmu obj - #+lispworks - (let ((stored (gensym))) - `(let ((,stored ,obj)) - (if (fli:null-pointer-p ,stored) - nil - (fli:convert-from-foreign-string ,stored)))) - #+allegro - (let ((stored (gensym))) - `(let ((,stored ,obj)) - (if (zerop ,stored) - nil - (values (excl:native-to-string ,stored))))) - #+mcl - (let ((stored (gensym))) - `(let ((,stored ,obj)) - (if (ccl:%null-ptr-p ,stored) - nil - (values (ccl:%get-cstring ,stored))))) - - - ) - -(defmacro convert-to-cstring (obj) - #+lispworks - `(if (null ,obj) - +null-cstring-pointer+ - (fli:convert-to-foreign-string ,obj)) - #+allegro - `(if (null ,obj) - 0 - (values (excl:string-to-native ,obj))) - #+cmu - (declare (ignore obj)) - #+mcl - `(if (null ,obj) - +null-cstring-pointer+ - (let ((ptr (new-ptr (1+ (length ,obj))))) - (ccl:%put-cstring ptr ,obj) - ptr)) - ) - -(defmacro free-cstring (obj) - #+lispworks - `(unless (fli:null-pointer-p ,obj) - (fli:free-foreign-object ,obj)) - #+allegro - `(unless (zerop obj) - (ff:free-fobject ,obj)) - #+cmu - (declare (ignore obj)) - #+mcl - `(unless (ccl:%null-ptr-p ,obj) - (dispose-ptr ,obj)) - - ) - -;; Either length or null-terminated-p must be non-nil -(defmacro convert-from-foreign-string (obj &key - length - (null-terminated-p t)) - #+allegro - `(if (zerop ,obj) - nil - (values (excl:native-to-string - ,obj - ,@(if length (list :length length) (values)) - :truncate (not ,null-terminated-p)))) - #+lispworks - `(if (fli:null-pointer-p ,obj) - nil - (fli:convert-from-foreign-string - ,obj - ,@(if length (list :length length) (values)) - :null-terminated-p ,null-terminated-p - :external-format '(:latin-1 :eol-style :lf))) - #+cmu - `(cmucl-naturalize-cstring (alien:alien-sap ,obj) - :length ,length - :null-terminated-p ,null-terminated-p) - #+mcl - (declare (ignore null-terminated-p)) - #+mcl - `(if (ccl:%null-ptr-p ,obj) - nil - (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil))) - ) - -(defmacro convert-to-foreign-string (obj) - #+lispworks - `(if (null ,obj) - +null-cstring-pointer+ - (fli:convert-to-foreign-string ,obj)) - #+allegro - `(if (null ,obj) - 0 - (values (excl:string-to-native ,obj))) - #+cmu - (let ((size (gensym)) - (storage (gensym)) - (i (gensym))) - `(when (stringp ,obj) - (let* ((,size (length ,obj)) - (,storage (alien:make-alien char (1+ ,size)))) - (setq ,storage (alien:cast ,storage (* char))) - (dotimes (,i ,size) - (declare (fixnum ,i) - (optimize (speed 3) (safety 0))) - (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i)))) - (setf (alien:deref ,storage ,size) 0) - ,storage))) - #+mcl - `(if (null ,obj) - +null-cstring-pointer+ - (let ((ptr (new-ptr (1+ (length ,obj))))) - (ccl:%put-cstring ptr ,obj) - ptr)) - ) - - -(defmacro allocate-foreign-string (size &key (unsigned t)) - #+cmu - (let ((array-def (gensym))) - `(let ((,array-def (list 'alien:array 'c-call:char ,size))) - (eval `(alien:cast (alien:make-alien ,,array-def) - ,(if ,unsigned - '(* (alien:unsigned 8)) - '(* (alien:signed 8))))))) - #+lispworks - `(fli:allocate-foreign-object :type - ,(if unsigned - ''(:unsigned :char) - :char) - :nelems ,size) - #+allegro - (declare (ignore unsigned)) - #+allegro - `(ff:allocate-fobject :char :c ,size) - #+mcl - (declare (ignore unsigned)) - #+mcl - `(new-ptr ,size) - - ) - - -; I'm sure there must be a better way to write this... -(defmacro with-cstring ((foreign-string lisp-string) &body body) - `(if (stringp ,lisp-string) - (ccl:with-cstrs ((,foreign-string ,lisp-string)) - ,@body) - (let ((,foreign-string +null-cstring-pointer+)) - ,@body))) - - -#| Works but, supposedly the built in method is better -(defmacro with-cstring ((foreign-string lisp-string) &body body) - (let ((result (gensym))) - `(let* ((,foreign-string (convert-to-cstring ,lisp-string)) - (,result ,@body)) - (dispose-ptr ,foreign-string) - ,result)) - ) - -|# - - - - - diff --git a/uffi/objects.cl b/uffi/objects.cl deleted file mode 100644 index 3190d18..0000000 --- a/uffi/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/08/02 14:39:12 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/uffi/package.cl b/uffi/package.cl deleted file mode 100644 index abacbc8..0000000 --- a/uffi/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/uffi/primitives.cl b/uffi/primitives.cl deleted file mode 100644 index 0873e34..0000000 --- a/uffi/primitives.cl +++ /dev/null @@ -1,198 +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.2 2002/08/03 06:34:30 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - -(defmacro def-constant (name value &key (export nil)) - "Macro to define a constant and to export it" - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant ,name ,value) - ,(when export (list 'export `(quote ,name))) - ',name)) - -(defmacro def-type (name type) - "Generates a (deftype) statement for CL. Currently, only CMUCL -supports takes advantage of this optimization." - #+(or lispworks allegro) - (declare (ignore type)) - #+(or lispworks allegro) - `(deftype ,name () t) - #+cmu - `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare))) - #+sbcl - `(deftype ,name () '(sb-alien:alien ,(convert-from-uffi-type type :declare))) - ) - -(defmacro null-char-p (val) - "Returns T if character is NULL" - `(zerop ,val)) - -(defmacro def-foreign-type (name type) - #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type)) - #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type)) - #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type)) - #+sbcl `(sb-alien:def-alien-type ,name ,(convert-from-uffi-type type :type)) - ) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar +type-conversion-hash+ (make-hash-table :size 20)) - #+(or cmu sbcl) (defvar +cmu-def-type-hash+ (make-hash-table :size 20)) - ) - -#+cmu -(defconstant +cmu-def-type-list+ - '((:char . (alien:signed 8)) - (:unsigned-char . (alien:unsigned 8)) - (:byte . (alien:signed 8)) - (:unsigned-byte . (alien:unsigned 8)) - (:short . (alien:signed 16)) - (:unsigned-short . (alien:unsigned 16)) - (:int . (alien:signed 32)) - (:unsigned-int . (alien:unsigned 32)) - (:long . (alien:signed 32)) - (:unsigned-long . (alien:unsigned 32)) - (:float . alien:single-float) - (:double . alien:double-float) - ) - "Conversions in CMUCL for def-foreign-type are different than in def-function") -#+sbcl -(defconstant +cmu-def-type-list+ - '((:char . (sb-alien:signed 8)) - (:unsigned-char . (sb-alien:unsigned 8)) - (:byte . (sb-alien:signed 8)) - (:unsigned-byte . (sb-alien:unsigned 8)) - (:short . (sb-alien:signed 16)) - (:unsigned-short . (sb-alien:unsigned 16)) - (:int . (sb-alien:signed 32)) - (:unsigned-int . (sb-alien:unsigned 32)) - (:long . (sb-alien:signed 32)) - (:unsigned-long . (sb-alien:unsigned 32)) - (:float . sb-alien:single-float) - (:double . sb-alien:double-float) - ) - "Conversions in SBCL for def-foreign-type are different than in def-function") - -(defparameter +type-conversion-list+ nil) - -#+cmu -(setq +type-conversion-list+ - '((* . *) (:void . c-call:void) - (:short . c-call:short) - (:pointer-void . (* t)) - (:cstring . c-call:c-string) - (:char . c-call:char) - (:unsigned-char . (alien:unsigned 8)) - (:byte . (alien:signed 8)) - (:unsigned-byte . (alien:unsigned 8)) - (:short . c-call:unsigned-short) - (:unsigned-short . c-call:unsigned-short) - (:int . alien:integer) (:unsigned-int . c-call:unsigned-int) - (:long . c-call:long) (:unsigned-long . c-call:unsigned-long) - (:float . c-call:float) (:double . c-call:double) - (:array . alien:array))) - -#+sbcl -(setq +type-conversion-list+ - '((* . *) (:void . void) - (:short . short) - (:pointer-void . (* t)) - (:cstring . c-string) - (:char . char) - (:unsigned-char . (sb-alien:unsigned 8)) - (:byte . (sb-alien:signed 8)) - (:unsigned-byte . (sb-alien:unsigned 8)) - (:short . unsigned-short) - (:unsigned-short . unsigned-short) - (:int . integer) (:unsigned-int . unsigned-int) - (:long . long) (:unsigned-long . unsigned-long) - (:float . float) (:double . double) - (:array . array))) - -#+allegro -(setq +type-conversion-list+ - '((* . *) (:void . :void) - (:short . :short) - (:pointer-void . (* :void)) - (:cstring . (* :unsigned-char)) - (:byte . :char) - (:unsigned-byte . :unsigned-byte) - (:char . :char) - (:unsigned-char . :unsigned-char) - (:int . :int) (:unsigned-int . :unsigned-int) - (:long . :long) (:unsigned-long . :unsigned-long) - (:float . :float) (:double . :double) - (:array . :array))) -#+lispworks -(setq +type-conversion-list+ - '((* . :pointer) (:void . :void) - (:short . :short) - (:pointer-void . (:pointer :void)) - (:cstring . (:reference-pass (:ef-mb-string :external-format :latin-1) - :allow-null t)) - (:cstring-returning . (:reference (:ef-mb-string :external-format :latin-1) :allow-null t)) - (:byte . :byte) - (:unsigned-byte . (:unsigned :byte)) - (:char . :char) - (:unsigned-char . (:unsigned :char)) - (:int . :int) (:unsigned-int . (:unsigned :int)) - (:long . :long) (:unsigned-long . (:unsigned :long)) - (:float . :float) (:double . :double) - (:array . :c-array))) - -(dolist (type +type-conversion-list+) - (setf (gethash (car type) +type-conversion-hash+) (cdr type))) - -#+(or cmu sbcl) -(dolist (type +cmu-def-type-list+) - (setf (gethash (car type) +cmu-def-type-hash+) (cdr type))) - -(defun basic-convert-from-uffi-type (type) - (let ((found-type (gethash type +type-conversion-hash+))) - (if found-type - found-type - type))) - -(defun convert-from-uffi-type (type context) - "Converts from a uffi type to an implementation specific type" - (if (atom type) - (cond - #+allegro - ((and (or (eq context :routine) (eq context :return)) - (eq type :cstring)) - (setq type '((* :char) integer))) - #+(or cmu sbcl) - ((eq context :type) - (let ((cmu-type (gethash type +cmu-def-type-hash+))) - (if cmu-type - cmu-type - (basic-convert-from-uffi-type type)))) - #+lispworks - ((and (eq context :return) - (eq type :cstring)) - (basic-convert-from-uffi-type :cstring-returning)) - (t - (basic-convert-from-uffi-type type))) - (cons (convert-from-uffi-type (first type) context) - (convert-from-uffi-type (rest type) context)))) - - - - - - diff --git a/uffi/strings.cl b/uffi/strings.cl deleted file mode 100644 index b28d60a..0000000 --- a/uffi/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.1 2002/08/02 14:39:12 kevin Exp $ -;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :uffi) - - -(def-constant +null-cstring-pointer+ - #+cmu nil - #+allegro 0 - #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char)) - #-(or cmu allegro lispworks) nil -) - -(defmacro convert-from-cstring (obj) - "Converts a string from a c-call. Same as convert-from-foreign-string, except -that LW/CMU automatically converts strings from c-calls." - #+cmu obj - #+lispworks obj - #+allegro - (let ((stored (gensym))) - `(let ((,stored ,obj)) - (if (zerop ,stored) - nil - (values (excl:native-to-string ,stored))))) - ) - -(defmacro convert-to-cstring (obj) - #+cmu obj - #+lispworks obj - #+allegro - `(if (null ,obj) - 0 - (values (excl:string-to-native ,obj))) - ) - -(defmacro free-cstring (obj) - #+cmu (declare (ignore obj)) - #+lispworks (declare (ignore obj)) - #+allegro - `(unless (zerop obj) - (ff:free-fobject ,obj)) - ) - -(defmacro with-cstring ((cstring lisp-string) &body body) - #+cmu - `(let ((,cstring ,lisp-string)) ,@body) - #+lispworks - `(let ((,cstring ,lisp-string)) ,@body) - #+allegro - (let ((acl-native (gensym))) - `(excl:with-native-string (,acl-native ,lisp-string) - (let ((,cstring (if ,lisp-string ,acl-native 0))) - ,@body))) - ) - -(defmacro with-cstrings (bindings &rest body) - (if bindings - `(with-cstring ,(car bindings) - (with-cstrings ,(cdr bindings) - ,@body)) - `(progn ,@body))) - -;;; Foreign string functions - -(defmacro convert-to-foreign-string (obj) - #+lispworks - `(if (null ,obj) - +null-cstring-pointer+ - (fli:convert-to-foreign-string ,obj)) - #+allegro - `(if (null ,obj) - 0 - (values (excl:string-to-native ,obj))) - #+cmu - (let ((size (gensym)) - (storage (gensym)) - (i (gensym))) - `(etypecase ,obj - (null - (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8)))) - (string - (let* ((,size (length ,obj)) - (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size)))) - (setq ,storage (alien:cast ,storage (* (alien:unsigned 8)))) - (locally - (declare (optimize (speed 3) (safety 0))) - (dotimes (,i ,size) - (declare (fixnum ,i)) - (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i)))) - (setf (alien:deref ,storage ,size) 0)) - ,storage)))) - ) - - -;; Either length or null-terminated-p must be non-nil -(defmacro convert-from-foreign-string (obj &key - length - (null-terminated-p t)) - #+allegro - `(if (zerop ,obj) - nil - (values (excl:native-to-string - ,obj - ,@(if length (list :length length) (values)) - :truncate (not ,null-terminated-p)))) - #+lispworks - `(if (fli:null-pointer-p ,obj) - nil - (fli:convert-from-foreign-string - ,obj - ,@(if length (list :length length) (values)) - :null-terminated-p ,null-terminated-p - :external-format '(:latin-1 :eol-style :lf))) - #+cmu - `(if (null-pointer-p ,obj) - nil - (cmucl-naturalize-cstring (alien:alien-sap ,obj) - :length ,length - :null-terminated-p ,null-terminated-p)) - ) - - - -(defmacro allocate-foreign-string (size &key (unsigned t)) - #+cmu - (let ((array-def (gensym))) - `(let ((,array-def (list 'alien:array 'c-call:char ,size))) - (eval `(alien:cast (alien:make-alien ,,array-def) - ,(if ,unsigned - '(* (alien:unsigned 8)) - '(* (alien:signed 8))))))) - #+lispworks - `(fli:allocate-foreign-object :type - ,(if unsigned - ''(:unsigned :char) - :char) - :nelems ,size) - #+allegro - (declare (ignore unsigned)) - #+allegro - `(ff:allocate-fobject :char :c ,size) - ) - -(defmacro with-foreign-string ((foreign-string lisp-string) &body body) - (let ((result (gensym))) - `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string)) - (,result (progn ,@body))) - (declare (dynamic-extent ,foreign-string)) - (free-foreign-object ,foreign-string) - ,result))) - - -;; Modified from CMUCL's source to handle non-null terminated strings -#+cmu -(defun cmucl-naturalize-cstring (sap &key - length - (null-terminated-p t)) - (declare (type system:system-area-pointer sap)) - (locally - (declare (optimize (speed 3) (safety 0))) - (let ((null-terminated-length - (when null-terminated-p - (loop - for offset of-type fixnum upfrom 0 - until (zerop (system:sap-ref-8 sap offset)) - finally (return offset))))) - (if length - (if (and null-terminated-length - (> (the fixnum length) (the fixnum null-terminated-length))) - (setq length null-terminated-length)) - (setq length null-terminated-length))) - (let ((result (make-string length))) - (kernel:copy-from-system-area sap 0 - result (* vm:vector-data-offset - vm:word-bits) - (* length vm:byte-bits)) - result)))