From: espen Date: Tue, 25 Apr 2006 20:28:13 +0000 (+0000) Subject: Initial checkin X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/commitdiff_plain/b286c6ed2b306af55fc67fff532136418a70c73f Initial checkin --- diff --git a/gffi/defpackage.lisp b/gffi/defpackage.lisp new file mode 100644 index 0000000..68cf044 --- /dev/null +++ b/gffi/defpackage.lisp @@ -0,0 +1,91 @@ +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 2006 Espen S. Johnsen +;; +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +;; $Id: defpackage.lisp,v 1.1 2006-04-25 20:29:14 espen Exp $ + +(defpackage "GFFI" + (:use "COMMON-LISP" "AUTOEXPORT" "PKG-CONFIG" "CLG-UTILS") + #+cmu(:use "SYSTEM" "KERNEL" "PCL" "EXT") + #+sbcl(:use "SB-SYS" "SB-KERNEL" "SB-MOP" "SB-EXT") + #+clisp(:use "CLOS" "EXT") + #+(or cmu sbcl)(:shadow "POINTER") + #+cmu(:shadowing-import-from "PCL" "CLASS-DIRECT-SUPERCLASSES") + #+clisp(:shadow "TYPE-EXPAND-1" "SLOT-DEFINITION-TYPE") + #+(or cmu sbcl) + (:import-from #+cmu"PCL" #+sbcl"SB-PCL" + "READER-FUNCTION" "WRITER-FUNCTION" "BOUNDP-FUNCTION" + "INITIALIZE-INTERNAL-SLOT-FUNCTIONS" "COMPUTE-SLOT-ACCESSOR-INFO" + "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS" + #?-(pkg-config:sbcl>= 0 9 8)"INITIALIZE-INTERNAL-SLOT-GFS") + #+cmu(:import-from "ALIEN" "CALLBACK") + #+(or cmu sbcl) + (:import-from #+cmu"ALIEN" #+sbcl"SB-ALIEN" + "WITH-ALIEN" "ALIEN-FUNCALL" "%HEAP-ALIEN" "MAKE-HEAP-ALIEN-INFO" + "ADDR" "PARSE-ALIEN-TYPE" "SYSTEM-AREA-POINTER" "EXTERN-ALIEN" + "ALIEN-SAP") + #+cmu(:import-from "C-CALL" "VOID" "C-STRING") + #+sbcl(:import-from "SB-ALIEN" "VOID" "C-STRING") + ;; Symbols from memory.lisp + (:export "MAKE-POINTER" "POINTER-ADDRESS" "NULL-POINTER-P" "POINTER=" + "POINTER+" "REF-POINTER" "REF-BYTE" "ALLOCATE-MEMORY" + "DEALLOCATE-MEMORY" "COPY-MEMORY" "CLEAR-MEMORY" "MEMORY-CLEAR-P" + "WITH-MEMORY" "WITH-POINTER") + ;; Symbols from interface.lisp + (:export "DEFBINDING" "MKBINDING" "USE-PREFIX" "PACKAGE-PREFIX" + "DEFINE-CALLBACK" "CALLBACK" "CALLBACK-ADDRESS" + "DEFINE-TYPE-GENERIC" "DEFINE-TYPE-METHOD" "IN-ARG-P" "OUT-ARG-P" + "DEFAULT-ALIEN-TYPE-NAME" "DEFAULT-TYPE-NAME" "TYPE-EXPAND" + "TYPE-EXPAND-1" "TYPE-EXPAND-TO") + ;; Symbols from basic-types.lisp + (:export "LONG" "UNSIGNED-LONG" "INT" "UNSIGNED-INT" "SHORT" + "UNSIGNED-SHORT" "SIGNED" "UNSIGNED" "CHAR" "POINTER" + "BOOL" "COPY-OF" "STATIC" "SIZE-OF" "ALIEN-TYPE" "UNBOUND-VALUE" + "ALIEN-ARG-WRAPPER" "TO-ALIEN-FORM" "FROM-ALIEN-FORM" + "CALLBACK-WRAPPER" "TO-ALIEN-FUNCTION" "FROM-ALIEN-FUNCTION" + "READER-FUNCTION" "WRITER-FUNCTION" "GETTER-FUNCTION" + "PEEK-FUNCTION" "DESTROY-FUNCTION" "UNBOUND-VALUE" + "COPY-FUNCTION" "ASSERT-INLINED" "ASSERT-NOT-INLINED") + ;; Symbols from vector.lisp + (:export "MAKE-C-VECTOR" "MAP-C-VECTOR" "WITH-C-VECTOR" "COUNTED-VECTOR" + "NULL-TERMINATED-VECTOR") + ;; Symbols from enums.lisp + (:export "ENUM" "ENUM-INT" "INT-ENUM" "ENUM-MAPPING" "DEFINE-ENUM-TYPE" + "FLAGS" "DEFINE-FLAGS-TYPE") + ;; Symbols from virtual-slots.lisp + (:export "VIRTUAL-SLOTS-CLASS" "DIRECT-VIRTUAL-SLOT-DEFINITION" + "EFFECTIVE-VIRTUAL-SLOT-DEFINITION" "DIRECT-SPECIAL-SLOT-DEFINITION" + "EFFECTIVE-SPECIAL-SLOT-DEFINITION" "COMPUTE-MOST-SPECIFIC-INITARGS" + "MOST-SPECIFIC-SLOT-VALUE" "VIRTUAL-SLOTS-OBJECT" + "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS" "BOUNDP-FUNCTION" + "COMPUTE-SLOT-READER-FUNCTION" "COMPUTE-SLOT-BOUNDP-FUNCTION" + "COMPUTE-SLOT-WRITER-FUNCTION" "COMPUTE-SLOT-MAKUNBOUND-FUNCTION" + #+clisp"SLOT-DEFINITION-TYPE") + ;; Symbols from proxy.lisp + (:export "CACHE-INSTANCE" "FIND-CACHED-INSTANCE" "LIST-CACHED-INSTANCES" + "REMOVE-CACHED-INSTANCE" "PROXY" "INSTANCE-FINALIZER" + "REFERENCE-FUNCTION" "UNREFERENCE-FUNCTION" "INVALIDATE-INSTANCE" + "ALLOCATE-FOREIGN" "FOREIGN-LOCATION" "PROXY-VALID-P" + "MOST-SPECIFIC-PROXY-SUPERCLASS" "DIRECT-PROXY-SUPERCLASS" + "PROXY-CLASS" "FOREIGN-SIZE-P" "DIRECT-ALIEN-SLOT-DEFINITION" + "EFFECTIVE-ALIEN-SLOT-DEFINITION" "FOREIGN-SIZE" "REF" "UNREF" + "ENSURE-PROXY-INSTANCE" "MAKE-PROXY-INSTANCE" "STRUCT" + "STRUCT-CLASS" "STATIC-STRUCT-CLASS" "INLINED")) diff --git a/gffi/gffi.asd b/gffi/gffi.asd new file mode 100644 index 0000000..4083f0d --- /dev/null +++ b/gffi/gffi.asd @@ -0,0 +1,38 @@ +;;; -*- Mode: lisp -*- + +(asdf:oos 'asdf:load-op :clg-tools) + +(defpackage "GFFI-SYSTEM" + (:use "COMMON-LISP" "ASDF" "PKG-CONFIG")) + +#+cmu(ext:unlock-all-packages) +#+sbcl +(progn + (sb-ext:unlock-package "COMMON-LISP") + (sb-ext:unlock-package "SB-PCL")) + +(in-package "GFFI-SYSTEM") + + +#+(and sbcl (not alien-callbacks)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-symbol "DEFINE-ALIEN-FUNCTION" "SB-ALIEN") + (error "You need to upgrade SBCL to a version with native C callback support or see the README file about how to add third party callbacks to your current SBCL version."))) + +#+(and sbcl alien-callbacks) +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (find-symbol "DEFINE-ALIEN-FUNCTION" "SB-ALIEN") + (error "Third party C callback code detected in a SBCL image with native callback support. As clg now uses native callbacks when available, you need to use a \"clean\" core file."))) + + +(defsystem gffi + :depends-on (clg-tools) + :components ((:file "defpackage") + #+(and cmu19a (not non-broken-pcl))(:file "pcl") + (:file "memory" :depends-on ("defpackage")) + (:file "interface" :depends-on ("memory")) + (:file "basic-types" :depends-on ("interface")) + (:file "vectors" :depends-on ("basic-types")) + (:file "enums" :depends-on ("basic-types")) + (:file "virtual-slots" :depends-on (#+(and cmu19a (not non-broken-pcl))"pcl" "interface" "basic-types")) + (:file "proxy" :depends-on ("virtual-slots")))) diff --git a/gffi/memory.lisp b/gffi/memory.lisp new file mode 100644 index 0000000..b84cb40 --- /dev/null +++ b/gffi/memory.lisp @@ -0,0 +1,144 @@ +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 1999-2006 Espen S. Johnsen +;; +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +;; $Id: memory.lisp,v 1.1 2006-04-25 20:31:35 espen Exp $ + + +(in-package "GFFI") + + +(defun make-pointer (address) + #+(or cmu sbcl)(int-sap address) + #+clisp(ffi:unsigned-foreign-address address) + #-(or cmu sbcl clisp)address) + +(defun pointer-address (pointer) + #+(or cmu sbcl)(sap-int pointer) + #+clisp(ffi:foreign-address-unsigned pointer) + #-(or cmu sbcl clisp)pointer) + +(defun null-pointer-p (pointer) + #+(or cmu sbcl)(zerop (sap-int pointer)) + #+clisp(or (not pointer) (zerop (pointer-address pointer))) + #-(or cmu sbcl clisp)(zerop pointer)) + +(defun pointer= (pointer1 pointer2) + #+(or cmu sbcl)(sap= pointer1 pointer2) + #+clisp(= (pointer-address pointer1) (pointer-address pointer2)) + #-(or cmu sbcl clisp)(= pointer1 pointer2)) + +(defun pointer+ (pointer offset) + #+(or cmu sbcl)(sap+ pointer offset) + #+clisp(make-pointer (+ (pointer-address pointer) offset)) + #-(or cmu sbcl clisp)(+ pointer offset)) + +(defun ref-pointer (location &optional (offset 0)) + #+(or cmu sbcl)(sap-ref-sap location offset) + #+clisp(ffi:memory-as location 'ffi:c-pointer offset)) + +(defun (setf ref-pointer) (pointer location &optional (offset 0)) + (setf + #+(or cmu sbcl)(sap-ref-sap location offset) + #+clisp(ffi:memory-as location 'ffi:c-pointer offset) + pointer)) + +(defun ref-byte (location &optional (offset 0)) + #+(or cmu sbcl)(sap-ref-8 location offset) + #+clisp(ffi:memory-as location 'ffi:uchar offset)) + +(defun (setf ref-byte) (byte location &optional (offset 0)) + (setf + #+(or cmu sbcl)(sap-ref-8 location offset) + #+clisp(ffi:memory-as location 'ffi:uchar offset) + byte)) + +(defun allocate-memory (size) + (declare (ignore size)) + (error "Memory allocator not set")) +(declaim (ftype (function (integer) system-area-pointer) allocate-memory)) + +(defun deallocate-memory (location) + (declare (ignore location)) + (warn "Memory deallocator not set")) + +(defun copy-memory (from length &optional (to (allocate-memory length))) + #+cmu(system-area-copy from 0 to 0 (* 8 length)) + #+sbcl(system-area-ub8-copy from 0 to 0 length) + #-(or cmu sbcl) + (loop + for offset below length + do (setf (ref-byte to offset) (ref-byte from offset))) + to) + +(defun clear-memory (from length &optional (offset 0)) + #+sbcl(system-area-ub8-fill 0 from offset length) + #-sbcl + (loop + repeat length + for byte-offset from offset + do (setf (ref-byte from byte-offset) 0))) + +(defun memory-clear-p (from length &optional (offset 0)) + (loop + repeat length + for byte-offset from offset + unless (zerop (ref-byte from byte-offset)) + do (return-from memory-clear-p nil)) + t) + +(defmacro with-memory ((var size) &body body) + #-clisp + (if (and #+(or cmu sbcl)t (constantp size)) + (let ((memory (make-symbol "MEMORY")) + (size (eval size))) + `(with-alien ((,memory (array #+sbcl(sb-alien:unsigned 8) #+cmu(alien:unsigned 8) ,size))) + (let ((,var (alien-sap ,memory))) + (clear-memory ,var ,size) + ,@body))) + `(let ((,var (allocate-memory ,size))) + (unwind-protect + (progn ,@body) + (deallocate-memory ,var)))) + #+clisp + (let ((memory (make-symbol "MEMORY"))) + `(ffi:with-foreign-object (,memory `(ffi:c-array ffi:uint8 ,,size)) + (let ((,var (ffi:foreign-address ,memory))) + ,@body)))) + +(defmacro with-pointer ((var &optional (pointer '(make-pointer 0))) &body body) + "Binds POINTER to VAR in a way which makes it possible to pass the location of VAR to in foreign function call." + #+(or cmu sbcl) + `(with-alien ((,var system-area-pointer ,pointer)) + ,@body) + #+clisp + `(ffi:with-c-var (,var `ffi:c-pointer ,pointer) + ,@body)) + + +#+sbcl +(progn + (defun sb-sizeof-bits (type) + (sb-alien-internals:alien-type-bits + (sb-alien-internals:parse-alien-type type nil))) + + (defun sb-sizeof (type) + (/ (sb-sizeof-bits type) 8)))