--- /dev/null
+;; Common Lisp bindings for GTK+ v2.x
+;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
+;;
+;; 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: basic-types.lisp,v 1.1 2006-04-25 20:36:05 espen Exp $
+
+(in-package "GFFI")
+
+
+(deftype int ()
+ '(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:int)
+ #+clisp #.(ffi:bitsizeof 'ffi:int)
+ #-(or sbcl clisp) 32))
+(deftype unsigned-int ()
+ '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:int)
+ #+clisp #.(ffi:bitsizeof 'ffi:int)
+ #-(or sbcl clisp) 32))
+(deftype long ()
+ '(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:long)
+ #+clisp #.(ffi:bitsizeof 'ffi:long)
+ #-(or sbcl clisp) 32))
+(deftype unsigned-long ()
+ '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:long)
+ #+clisp #.(ffi:bitsizeof 'ffi:long)
+ #-(or sbcl clisp) 32))
+(deftype short ()
+ '(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:short)
+ #+clisp #.(ffi:bitsizeof 'ffi:short)
+ #-(or sbcl clisp) 16))
+(deftype unsigned-short ()
+ '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:short)
+ #+clisp #.(ffi:bitsizeof 'ffi:short)
+ #-(or sbcl clisp) 16))
+(deftype signed (&optional (size '*)) `(signed-byte ,size))
+(deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
+(deftype char () 'base-char)
+(deftype pointer ()
+ #+(or cmu sbcl) 'system-area-pointer
+ #+clisp 'ffi:foreign-address)
+(deftype bool (&optional (size '*)) (declare (ignore size)) 'boolean)
+(deftype copy-of (type) type)
+(deftype static (type) type)
+(deftype inlined (type) type)
+
+
+
+(define-type-generic alien-type (type)
+ "Returns the foreign type corresponding to TYPE")
+(define-type-generic size-of (type &key inlined)
+ "Returns the foreign size of TYPE. The default value of INLINED is
+T for basic C types and NIL for other types.")
+(define-type-generic alien-arg-wrapper (type var arg style form &optional copy-p)
+ "Creates a wrapper around FORM which binds the alien translation of
+ARG to VAR in a way which makes it possible to pass the location of
+VAR in a foreign function call. It should also do any necessary clean
+up before returning the value of FORM.")
+(define-type-generic to-alien-form (type form &optional copy-p)
+ "Returns a form which translates FORM to alien representation. If
+COPY-P is non NIL then any allocated foreign memory must not be
+reclaimed later.")
+(define-type-generic from-alien-form (type form &key ref)
+ "Returns a form which translates FORM from alien to lisp
+representation. REF should be :FREE, :COPY, :STATIC or :TEMP")
+(define-type-generic to-alien-function (type &optional copy-p)
+ "Returns a function of one argument which will translate objects of the given type to alien repesentation. An optional function, taking the origional object and the alien representation as arguments, to clean up after the alien value is not needed any more may be returned as a second argument.")
+(define-type-generic from-alien-function (type &key ref)
+ "Returns a function of one argument which will translate alien objects of the given type to lisp representation. REF should be :FREE, :COPY, :STATIC or :TEMP")
+(define-type-generic callback-wrapper (type var arg form)
+ "Creates a wrapper around FORM which binds the lisp translation of
+ARG to VAR during a C callback.")
+
+(define-type-generic writer-function (type &key temp inlined)
+ "Returns a function taking a value, an address and an optional
+offset which when called will write a reference an object at the given
+location. If TEMP is non NIL then the object is expected to be valid
+as long as the reference exists.")
+(define-type-generic reader-function (type &key ref inlined)
+ "Returns a function taking an address and optional offset which when
+called will return the object at given location. REF should be :READ,
+:PEEK or :GET")
+(define-type-generic destroy-function (type &key temp inlined)
+ "Returns a function taking an address and optional offset which when
+called will destroy the reference at the given location. This may
+involve freeing the foreign object being referenced or decreasing it's
+ref. count. If TEMP is non NIL then the reference is expected to
+have been written as temporal.")
+(define-type-generic copy-function (type &key inlined))
+
+(define-type-generic unbound-value (type-spec)
+ "Returns a value which should be interpreted as unbound for slots with virtual allocation")
+
+(defun assert-inlined (type inlined-p)
+ (unless inlined-p
+ (error "Type ~A can only be inlined" type)))
+
+(defun assert-not-inlined (type inlined-p)
+ (when inlined-p
+ (error "Type ~A can not be inlined" type)))
+
+
+(define-type-method alien-arg-wrapper ((type t) var arg style form &optional
+ (copy-in-p nil copy-in-given-p))
+ (let ((alien-type (alien-type type)))
+ (cond
+ ((in-arg-p style)
+ (let ((to-alien (if copy-in-given-p
+ (to-alien-form type arg copy-in-p)
+ (to-alien-form type arg))))
+ #+(or cmu sbcl)
+ `(with-alien ((,var ,alien-type ,to-alien))
+ ,form)
+ #+clisp
+ `(ffi:with-c-var (,var ',alien-type ,to-alien)
+ ,form)))
+ ((out-arg-p style)
+ #+(or cmu sbcl)
+ `(with-alien ((,var ,alien-type))
+ (clear-memory (alien-sap (addr ,var)) ,(size-of type))
+ ,form)
+ #+clisp
+ `(ffi:with-c-var (,var ',alien-type)
+ ,form)))))
+
+(define-type-method callback-wrapper ((type t) var arg form)
+ `(let ((,var ,(from-alien-form type arg :ref :temp)))
+ ,form))
+
+(define-type-method alien-type ((type t))
+ (error "No alien type corresponding to the type specifier ~A" type))
+
+(define-type-method to-alien-form ((type t) form &optional copy-p)
+ (declare (ignore form copy-p))
+ (error "Not a valid type specifier for arguments: ~A" type))
+
+(define-type-method to-alien-function ((type t) &optional copy-p)
+ (declare (ignore copy-p))
+ (error "Not a valid type specifier for arguments: ~A" type))
+
+(define-type-method from-alien-form ((type t) form &key ref)
+ (declare (ignore form ref))
+ (error "Not a valid type specifier for return values: ~A" type))
+
+(define-type-method from-alien-function ((type t) &key ref)
+ (declare (ignore ref))
+ (error "Not a valid type specifier for return values: ~A" type))
+
+(define-type-method destroy-function ((type t) &key temp (inlined t inlined-p))
+ (declare (ignore temp))
+ (let ((size (if inlined-p
+ (size-of type :inlined inlined)
+ (size-of type))))
+ #'(lambda (location &optional (offset 0))
+ (clear-memory location size offset))))
+
+(define-type-method copy-function ((type t) &key (inlined t inlined-p))
+ (let ((size (if inlined-p
+ (size-of type :inlined inlined)
+ (size-of type))))
+ #'(lambda (from to &optional (offset 0))
+ (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
+
+(define-type-method to-alien-form ((type real) form &optional copy-p)
+ (declare (ignore type copy-p))
+ form)
+
+(define-type-method to-alien-function ((type real) &optional copy-p)
+ (declare (ignore type copy-p))
+ #'identity)
+
+(define-type-method from-alien-form ((type real) form &key ref)
+ (declare (ignore type ref))
+ form)
+
+(define-type-method from-alien-function ((type real) &key ref)
+ (declare (ignore type ref))
+ #'identity)
+
+
+(define-type-method alien-type ((type integer))
+ (declare (ignore type))
+ (alien-type 'signed-byte))
+
+(define-type-method size-of ((type integer) &key (inlined t))
+ (declare (ignore type))
+ (size-of 'signed-byte :inlined inlined))
+
+(define-type-method writer-function ((type integer) &key temp (inlined t))
+ (declare (ignore temp))
+ (assert-inlined type inlined)
+ (writer-function 'signed-byte))
+
+(define-type-method reader-function ((type integer) &key ref (inlined t))
+ (declare (ignore ref))
+ (assert-inlined type inlined)
+ (reader-function 'signed-byte))
+
+
+;;; Signed Byte
+
+(define-type-method alien-type ((type signed-byte))
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'signed-byte type)))
+ (let ((size (if (eq size '*)
+ (second (type-expand-to 'signed-byte 'int))
+ size)))
+ #+cmu
+ (ecase size
+ ( 8 '(alien:signed 8))
+ (16 '(alien:signed 16))
+ (32 '(alien:signed 32))
+ (64 '(alien:signed 64)))
+ #+sbcl
+ (ecase size
+ ( 8 '(sb-alien:signed 8))
+ (16 '(sb-alien:signed 16))
+ (32 '(sb-alien:signed 32))
+ (64 '(sb-alien:signed 64)))
+ #+clisp
+ (ecase size
+ ( 8 'ffi:sint8)
+ (16 'ffi:sint16)
+ (32 'ffi:sint32)
+ (64 'ffi:sint64)))))
+
+(define-type-method size-of ((type signed-byte) &key (inlined t))
+ (assert-inlined type inlined)
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'signed-byte type)))
+ (let ((size (if (eq size '*)
+ (second (type-expand-to 'signed-byte 'int))
+ size)))
+ (ecase size
+ ( 8 1)
+ (16 2)
+ (32 4)
+ (64 8)))))
+
+(define-type-method writer-function ((type signed-byte) &key temp (inlined t))
+ (declare (ignore temp))
+ (assert-inlined type inlined)
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'signed-byte type)))
+ (let ((size (if (eq size '*)
+ (second (type-expand-to 'signed-byte 'int))
+ size)))
+ (ecase size
+ ( 8 #'(lambda (value location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(signed-sap-ref-8 location offset)
+ #+clisp(ffi:memory-as location 'ffi:sint8 offset)
+ value)))
+ (16 #'(lambda (value location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(signed-sap-ref-16 location offset)
+ #+clisp(ffi:memory-as location 'ffi:sint16 offset)
+ value)))
+ (32 #'(lambda (value location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(signed-sap-ref-32 location offset)
+ #+clisp(ffi:memory-as location 'ffi:sint32 offset)
+ value)))
+ (64 #'(lambda (value location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(signed-sap-ref-64 location offset)
+ #+clisp(ffi:memory-as location 'ffi:sint64 offset)
+ value)))))))
+
+(define-type-method reader-function ((type signed-byte) &key ref (inlined t))
+ (declare (ignore ref))
+ (assert-inlined type inlined)
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'signed-byte type)))
+ (let ((size (if (eq size '*)
+ (second (type-expand-to 'signed-byte 'int))
+ size)))
+ (ecase size
+ ( 8 #'(lambda (location &optional (offset 0))
+ #+(or cmu sbcl)(signed-sap-ref-8 location offset)
+ #+clisp(ffi:memory-as location 'ffi:sint8 offset)))
+ (16 #'(lambda (location &optional (offset 0))
+ #+(or cmu sbcl)(signed-sap-ref-16 location offset)
+ #+clisp(ffi:memory-as location 'ffi:sint16 offset)))
+ (32 #'(lambda (location &optional (offset 0))
+ #+(or cmu sbcl)(signed-sap-ref-32 location offset)
+ #+clisp(ffi:memory-as location 'ffi:sint32 offset)))
+ (64 #'(lambda (location &optional (offset 0))
+ #+(or cmu sbcl)(signed-sap-ref-64 location offset)
+ #+clisp(ffi:memory-as location 'ffi:sint64 offset)))))))
+
+
+
+;;; Unsigned Byte
+
+(define-type-method alien-type ((type unsigned-byte))
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'unsigned-byte type)))
+ (let ((size (if (eq size '*)
+ (second (type-expand-to 'signed-byte 'int))
+ size)))
+ #+cmu
+ (ecase size
+ ( 8 '(alien:unsigned 8))
+ (16 '(alien:unsigned 16))
+ (32 '(alien:unsigned 32))
+ (64 '(alien:unsigned 64)))
+ #+sbcl
+ (ecase size
+ ( 8 '(sb-alien:unsigned 8))
+ (16 '(sb-alien:unsigned 16))
+ (32 '(sb-alien:unsigned 32))
+ (64 '(sb-alien:unsigned 64)))
+ #+clisp
+ (ecase size
+ ( 8 'ffi:uint8)
+ (16 'ffi:uint16)
+ (32 'ffi:uint32)
+ (64 'ffi:uint64)))))
+
+(define-type-method size-of ((type unsigned-byte) &key (inlined t))
+ (assert-inlined type inlined)
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'unsigned-byte type)))
+ (size-of `(signed ,size))))
+
+(define-type-method writer-function ((type unsigned-byte) &key temp (inlined t))
+ (declare (ignore temp))
+ (assert-inlined type inlined)
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'unsigned-byte type)))
+ (let ((size (if (eq size '*)
+ (second (type-expand-to 'signed-byte 'int))
+ size)))
+ (ecase size
+ ( 8 #'(lambda (value location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(sap-ref-8 location offset)
+ #+clisp(ffi:memory-as location 'ffi:uint8 offset)
+ value)))
+ (16 #'(lambda (value location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(sap-ref-16 location offset)
+ #+clisp(ffi:memory-as location 'ffi:uint16 offset)
+ value)))
+ (32 #'(lambda (value location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(sap-ref-32 location offset)
+ #+clisp(ffi:memory-as location 'ffi:uint32 offset)
+ value)))
+ (64 #'(lambda (value location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(sap-ref-64 location offset)
+ #+clisp(ffi:memory-as location 'ffi:uint64 offset)
+ value)))))))
+
+(define-type-method reader-function ((type unsigned-byte) &key ref (inlined t))
+ (declare (ignore ref))
+ (assert-inlined type inlined)
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'unsigned-byte type)))
+ (let ((size (if (eq size '*)
+ (second (type-expand-to 'signed-byte 'int))
+ size)))
+ (ecase size
+ ( 8 #'(lambda (location &optional (offset 0))
+ #+(or cmu sbcl)(sap-ref-8 location offset)
+ #+clisp(ffi:memory-as location 'ffi:uint8 offset)))
+ (16 #'(lambda (location &optional (offset 0))
+ #+(or cmu sbcl)(sap-ref-16 location offset)
+ #+clisp(ffi:memory-as location 'ffi:uint16 offset)))
+ (32 #'(lambda (location &optional (offset 0))
+ #+(or cmu sbcl)(sap-ref-32 location offset)
+ #+clisp(ffi:memory-as location 'ffi:uint32 offset)))
+ (64 #'(lambda (location &optional (offset 0))
+ #+(or cmu sbcl)(sap-ref-64 location offset)
+ #+clisp(ffi:memory-as location 'ffi:uint64 offset)))))))
+
+
+
+;;; Single Float
+
+(define-type-method alien-type ((type single-float))
+ (declare (ignore type))
+ #+cmu 'alien:single-float
+ #+sbcl 'sb-alien:single-float
+ #+clisp 'single-float)
+
+(define-type-method size-of ((type single-float) &key (inlined t))
+ (assert-inlined type inlined)
+ #+sbcl (sb-sizeof 'sb-alien:float)
+ #+clisp (ffi:sizeof 'single-float)
+ #-(or sbcl clisp) 4)
+
+(define-type-method to-alien-form ((type single-float) form &optional copy-p)
+ (declare (ignore type copy-p))
+ `(coerce ,form 'single-float))
+
+(define-type-method to-alien-function ((type single-float) &optional copy-p)
+ (declare (ignore type copy-p))
+ #'(lambda (number)
+ (coerce number 'single-float)))
+
+(define-type-method writer-function ((type single-float) &key temp (inlined t))
+ (declare (ignore temp))
+ (assert-inlined type inlined)
+ #'(lambda (value location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(sap-ref-single location offset)
+ #+clisp(ffi:memory-as location 'single-float offset)
+ (coerce value 'single-float))))
+
+(define-type-method reader-function ((type single-float) &key ref (inlined t))
+ (declare (ignore ref))
+ (assert-inlined type inlined)
+ #'(lambda (location &optional (offset 0))
+ #+(or cmu sbcl)(sap-ref-single location offset)
+ #+clisp(ffi:memory-as location 'single-float offset)))
+
+
+
+;;; Double Float
+
+(define-type-method alien-type ((type double-float))
+ (declare (ignore type))
+ #+cmu 'alien:double-float
+ #+sbcl 'sb-alien:double-float
+ #+clisp 'double-float)
+
+(define-type-method size-of ((type double-float) &key (inlined t))
+ (assert-inlined type inlined)
+ #+sbcl (sb-sizeof 'sb-alien:double)
+ #+clisp (ffi:sizeof 'double-float)
+ #-(or sbcl clisp) 8)
+
+(define-type-method to-alien-form ((type double-float) form &optional copy-p)
+ (declare (ignore type copy-p))
+ `(coerce ,form 'double-float))
+
+(define-type-method to-alien-function ((type double-float) &optional copy-p)
+ (declare (ignore type copy-p))
+ #'(lambda (number)
+ (coerce number 'double-float)))
+
+(define-type-method writer-function ((type double-float) &key temp (inlined t))
+ (declare (ignore temp))
+ (assert-inlined type inlined)
+ #'(lambda (value location &optional (offset 0))
+ (setf
+ #+(or cmu sbcl)(sap-ref-double location offset)
+ #+clisp(ffi:memory-as location 'double-float offset)
+ (coerce value 'double-float))))
+
+(define-type-method reader-function ((type double-float) &key ref (inlined t))
+ (declare (ignore ref))
+ (assert-inlined type inlined)
+ #'(lambda (location &optional (offset 0))
+ #+(or cmu sbcl)(sap-ref-double location offset)
+ #+clisp(ffi:memory-as location 'double-float offset)))
+
+
+
+;;; Character
+
+(define-type-method alien-type ((type base-char))
+ (declare (ignore type))
+ #+cmu 'c-call:char
+ #+sbcl 'sb-alien:char
+ #+clisp 'ffi:character)
+
+(define-type-method size-of ((type base-char) &key (inlined t))
+ (assert-inlined type inlined)
+ 1)
+
+(define-type-method to-alien-form ((type base-char) form &optional copy-p)
+ (declare (ignore type copy-p))
+ form)
+
+(define-type-method to-alien-function ((type base-char) &optional copy-p)
+ (declare (ignore type copy-p))
+ #'identity)
+
+(define-type-method from-alien-form ((type base-char) form &key ref)
+ (declare (ignore type ref))
+ form)
+
+(define-type-method from-alien-function ((type base-char) &key ref)
+ (declare (ignore type ref))
+ #'identity)
+
+(define-type-method writer-function ((type base-char) &key temp (inlined t))
+ (declare (ignore temp))
+ (assert-inlined type inlined)
+ #'(lambda (char location &optional (offset 0))
+ #+(or cmu sbcl)
+ (setf (sap-ref-8 location offset) (char-code char))
+ #+clisp(setf (ffi:memory-as location 'ffi:character offset) char)))
+
+(define-type-method reader-function ((type base-char) &key ref (inlined t))
+ (declare (ignore ref))
+ (assert-inlined type inlined)
+ #'(lambda (location &optional (offset 0))
+ #+(or cmu sbcl)(code-char (sap-ref-8 location offset))
+ #+clisp(ffi:memory-as location 'ffi:character offset)))
+
+
+
+;;; String
+
+(defun utf8-length (string)
+ (1+ (loop
+ for char across string
+ as char-code = (char-code char)
+ sum (cond
+ ((< char-code #x7F) 1)
+ ((< char-code #x7FF) 2)
+ ((< char-code #xFFFF) 3)
+ ((< char-code #x1FFFFF) 4)))))
+
+(defun encode-utf8-string (string &optional location)
+ (let ((location (or location (allocate-memory (utf8-length string)))))
+ (loop
+ for char across string
+ for i from 0
+ as char-code = (char-code char)
+ do (flet ((encode (size)
+ (let ((rem (mod size 6)))
+ (setf (ref-byte location i)
+ (deposit-field
+ #xFF (byte (- 7 rem) (1+ rem))
+ (ldb (byte rem (- size rem)) char-code)))
+ (loop
+ for pos from (- size rem 6) downto 0 by 6
+ do (setf (ref-byte location (incf i))
+ (+ 128 (ldb (byte 6 pos) char-code)))))))
+ (cond
+ ((< char-code #x80) (setf (ref-byte location i) char-code))
+ ((< char-code #x800) (encode 11))
+ ((< char-code #x10000) (encode 16))
+ ((< char-code #x200000) (encode 21))))
+ finally (setf (ref-byte location (1+ i)) 0))
+ location))
+
+(defun decode-utf8-string (c-string)
+ (with-output-to-string (string)
+ (loop
+ for i from 0
+ as octet = (ref-byte c-string i)
+ until (zerop octet)
+ do (flet ((decode (size)
+ (loop
+ with rem = (mod size 6)
+ for pos from (- size rem) downto 0 by 6
+ as code = (dpb (ldb (byte rem 0) octet) (byte rem pos) 0)
+ then (dpb
+ (ldb (byte 6 0) (ref-byte c-string (incf i)))
+ (byte 6 pos) code)
+ finally (write-char (code-char code) string))))
+ (cond
+ ((< octet 128) (write-char (code-char octet) string))
+ ((< octet 224) (decode 11))
+ ((< octet 240) (decode 16))
+ ((< octet 248) (decode 21)))))))
+
+
+(define-type-method alien-arg-wrapper ((type string) var string style form &optional copy-in-p)
+ (declare (ignore type))
+ (cond
+ ((and (in-arg-p style) copy-in-p)
+ `(with-pointer (,var (encode-utf8-string ,string))
+ ,form))
+ ((and (in-arg-p style) (not (out-arg-p style)))
+ `(with-memory (,var (utf8-length ,string))
+ (encode-utf8-string ,string ,var)
+ ,form))
+ ((and (in-arg-p style) (out-arg-p style))
+ (let ((c-string (make-symbol "C-STRING")))
+ `(with-memory (,c-string (utf8-length ,string))
+ (encode-utf8-string ,string ,c-string)
+ (with-pointer (,var ,c-string)
+ ,form))))
+ ((and (out-arg-p style) (not (in-arg-p style)))
+ `(with-pointer (,var)
+ ,form))))
+
+(define-type-method alien-type ((type string))
+ (declare (ignore type))
+ (alien-type 'pointer))
+
+(define-type-method size-of ((type string) &key inlined)
+ (assert-not-inlined type inlined)
+ (size-of 'pointer))
+
+(define-type-method to-alien-form ((type string) string &optional copy-p)
+ (declare (ignore type copy-p))
+ `(encode-utf8-string ,string))
+
+(define-type-method to-alien-function ((type string) &optional copy-p)
+ (declare (ignore type))
+ (values
+ #'encode-utf8-string
+ (unless copy-p
+ #'(lambda (string c-string)
+ (declare (ignore string))
+ (deallocate-memory c-string)))))
+
+(define-type-method from-alien-form ((type string) form &key (ref :free))
+ (declare (ignore type))
+ `(let ((c-string ,form))
+ (unless (null-pointer-p c-string)
+ (prog1
+ (decode-utf8-string c-string)
+ ,(when (eq ref :free)
+ `(deallocate-memory c-string))))))
+
+(define-type-method from-alien-function ((type string) &key (ref :free))
+ (declare (ignore type))
+ (if (eq ref :free)
+ #'(lambda (c-string)
+ (unless (null-pointer-p c-string)
+ (prog1
+ (decode-utf8-string c-string)
+ (deallocate-memory c-string))))
+ #'(lambda (c-string)
+ (unless (null-pointer-p c-string)
+ (decode-utf8-string c-string)))))
+
+(define-type-method writer-function ((type string) &key temp inlined)
+ (declare (ignore temp))
+ (assert-not-inlined type inlined)
+ #'(lambda (string location &optional (offset 0))
+ (assert (null-pointer-p (ref-pointer location offset)))
+ (setf (ref-pointer location offset) (encode-utf8-string string))))
+
+(define-type-method reader-function ((type string) &key (ref :read) inlined)
+ (assert-not-inlined type inlined)
+ (ecase ref
+ ((:read :peek)
+ #'(lambda (location &optional (offset 0))
+ (unless (null-pointer-p (ref-pointer location offset))
+ (decode-utf8-string (ref-pointer location offset)))))
+ (:get
+ #'(lambda (location &optional (offset 0))
+ (unless (null-pointer-p (ref-pointer location offset))
+ (prog1
+ (decode-utf8-string (ref-pointer location offset))
+ (deallocate-memory (ref-pointer location offset))
+ (setf (ref-pointer location offset) (make-pointer 0))))))))
+
+(define-type-method destroy-function ((type string) &key temp inlined)
+ (declare (ignore temp))
+ (assert-not-inlined type inlined)
+ #'(lambda (location &optional (offset 0))
+ (unless (null-pointer-p (ref-pointer location offset))
+ (deallocate-memory (ref-pointer location offset))
+ (setf (ref-pointer location offset) (make-pointer 0)))))
+
+(define-type-method copy-function ((type string) &key inlined)
+ (assert-not-inlined type inlined)
+ (lambda (from to &optional (offset 0))
+ (let* ((string (ref-pointer from offset))
+ (length (loop
+ for i from 0
+ until (zerop (ref-byte string i))
+ finally (return (1+ i)))))
+ (setf (ref-pointer to offset) (copy-memory string length)))))
+
+(define-type-method unbound-value ((type string))
+ (declare (ignore type))
+ nil)
+
+
+
+;;; Pathname
+
+(define-type-method alien-type ((type pathname))
+ (declare (ignore type))
+ (alien-type 'string))
+
+(define-type-method size-of ((type pathname) &key inlined)
+ (assert-not-inlined type inlined)
+ (size-of 'string))
+
+(define-type-method alien-arg-wrapper ((type pathname) var pathname style form &optional copy-in-p)
+ (declare (ignore type))
+ (alien-arg-wrapper 'string var `(namestring (translate-logical-pathname ,pathname)) style form copy-in-p))
+
+(define-type-method to-alien-form ((type pathname) path)
+ (declare (ignore type))
+ (to-alien-form 'string `(namestring (translate-logical-pathname ,path))))
+
+(define-type-method to-alien-function ((type pathname) &optional copy-p)
+ (declare (ignore type))
+ (let ((string-function (to-alien-function 'string copy-p)))
+ #'(lambda (path)
+ (funcall string-function (namestring path)))))
+
+(define-type-method from-alien-form ((type pathname) form &key (ref :free))
+ (declare (ignore type))
+ `(parse-namestring ,(from-alien-form 'string form :ref ref)))
+
+(define-type-method from-alien-function ((type pathname) &key (ref :free))
+ (declare (ignore type))
+ (let ((string-function (from-alien-function 'string :ref ref)))
+ #'(lambda (string)
+ (parse-namestring (funcall string-function string)))))
+
+(define-type-method writer-function ((type pathname) &key temp inlined)
+ (declare (ignore temp))
+ (assert-not-inlined type inlined)
+ (let ((string-writer (writer-function 'string)))
+ #'(lambda (path location &optional (offset 0))
+ (funcall string-writer (namestring path) location offset))))
+
+(define-type-method reader-function ((type pathname) &key ref inlined)
+ (declare (ignore ref))
+ (assert-not-inlined type inlined)
+ (let ((string-reader (reader-function 'string)))
+ #'(lambda (location &optional (offset 0))
+ (let ((string (funcall string-reader location offset)))
+ (when string
+ (parse-namestring string))))))
+
+(define-type-method destroy-function ((type pathname) &key temp inlined)
+ (declare (ignore temp))
+ (assert-not-inlined type inlined)
+ (destroy-function 'string))
+
+(define-type-method copy-function ((type pathname) &key inlined)
+ (assert-not-inlined type inlined)
+ (copy-function 'string))
+
+(define-type-method unbound-value ((type pathname))
+ (declare (ignore type))
+ (unbound-value 'string))
+
+
+
+;;; Bool
+
+(define-type-method alien-type ((type bool))
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'bool type)))
+ (alien-type `(signed-byte ,size))))
+
+(define-type-method size-of ((type bool) &key (inlined t))
+ (assert-inlined type inlined)
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'bool type)))
+ (size-of `(signed-byte ,size))))
+
+(define-type-method to-alien-form ((type bool) bool &optional copy-p)
+ (declare (ignore type copy-p))
+ `(if ,bool 1 0))
+
+(define-type-method to-alien-function ((type bool) &optional copy-p)
+ (declare (ignore type copy-p))
+ #'(lambda (bool)
+ (if bool 1 0)))
+
+(define-type-method from-alien-form ((type bool) form &key ref)
+ (declare (ignore type ref))
+ `(not (zerop ,form)))
+
+(define-type-method from-alien-function ((type bool) &key ref)
+ (declare (ignore type ref))
+ #'(lambda (bool)
+ (not (zerop bool))))
+
+(define-type-method writer-function ((type bool) &key temp (inlined t))
+ (declare (ignore temp))
+ (assert-inlined type inlined)
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'bool type)))
+ (let ((writer (writer-function `(signed-byte ,size))))
+ #'(lambda (bool location &optional (offset 0))
+ (funcall writer (if bool 1 0) location offset)))))
+
+(define-type-method reader-function ((type bool) &key ref (inlined t))
+ (declare (ignore ref))
+ (assert-inlined type inlined)
+ (destructuring-bind (&optional (size '*))
+ (rest (mklist (type-expand-to 'bool type)))
+ (let ((reader (reader-function `(signed-byte ,size))))
+ #'(lambda (location &optional (offset 0))
+ (not (zerop (funcall reader location offset)))))))
+
+
+
+;;; Boolean
+
+(define-type-method alien-type ((type boolean))
+ (declare (ignore type))
+ (alien-type 'bool))
+
+(define-type-method size-of ((type boolean) &key (inlined t))
+ (assert-inlined type inlined)
+ (size-of 'bool))
+
+(define-type-method to-alien-form ((type boolean) boolean &optional copy-p)
+ (declare (ignore type copy-p))
+ (to-alien-form 'bool boolean))
+
+(define-type-method to-alien-function ((type boolean) &optional copy-p)
+ (declare (ignore type copy-p))
+ (to-alien-function 'bool))
+
+(define-type-method from-alien-form ((type boolean) form &key ref)
+ (declare (ignore type ref))
+ (from-alien-form 'bool form))
+
+(define-type-method from-alien-function ((type boolean) &key ref)
+ (declare (ignore type ref))
+ (from-alien-function 'bool))
+
+(define-type-method writer-function ((type boolean) &key temp (inlined t))
+ (declare (ignore temp))
+ (assert-inlined type inlined)
+ (writer-function 'bool))
+
+(define-type-method reader-function ((type boolean) &key ref (inlined t))
+ (declare (ignore ref))
+ (assert-inlined type inlined)
+ (reader-function 'bool))
+
+
+;;; Or
+
+(define-type-method alien-type ((type or))
+ (let* ((expanded-type (type-expand-to 'or type))
+ (alien-type (alien-type (second expanded-type))))
+ (unless (every #'(lambda (type)
+ (eq alien-type (alien-type type)))
+ (cddr expanded-type))
+ (error "No common alien type specifier for union type: ~A" type))
+ alien-type))
+
+(define-type-method size-of ((type or) &key (inlined nil inlined-p))
+ (loop
+ for subtype in (type-expand-to 'or type)
+ maximize (if inlined-p
+ (size-of subtype inlined)
+ (size-of subtype))))
+
+(define-type-method alien-arg-wrapper ((type or) var value style form &optional copy-in-p)
+ (cond
+ ((and (in-arg-p style) (out-arg-p style))
+ `(etypecase ,value
+ ,@(mapcar
+ #'(lambda (type)
+ `(,type ,(alien-arg-wrapper type var value style form copy-in-p)))
+ (rest (type-expand-to 'or type)))))
+ ((in-arg-p style)
+ (let ((body (make-symbol "BODY")))
+ `(flet ((,body (,var)
+ ,form))
+ (etypecase ,value
+ ,@(mapcar
+ #'(lambda (type)
+ `(,type ,(alien-arg-wrapper type var value style `(,body ,var) copy-in-p)))
+ (rest (type-expand-to 'or type)))))))
+ ((out-arg-p style)
+ #+(or cmu sbcl)
+ `(with-alien ((,var ,(alien-type type)))
+ (clear-memory (alien-sap (addr ,var)) ,(size-of type))
+ ,form)
+ #+clisp
+ `(ffi:with-c-var (,var ',(alien-type type))
+ ,form))))
+
+(define-type-method to-alien-form ((type or) form &optional copy-p)
+ `(let ((value ,form))
+ (etypecase value
+ ,@(mapcar
+ #'(lambda (type)
+ `(,type ,(to-alien-form type 'value copy-p)))
+ (rest (type-expand-to 'or type))))))
+
+(define-type-method to-alien-function ((type or) &optional copy-p)
+ (let* ((expanded-type (type-expand-to 'or type))
+ (functions (loop
+ for type in (rest expanded-type)
+ collect (to-alien-function type copy-p))))
+ #'(lambda (value)
+ (loop
+ for function in functions
+ for alt-type in (rest expanded-type)
+ when (typep value alt-type)
+ do (return (funcall function value))
+ finally (error "~S is not of type ~A" value type)))))
+
+
+;;; Pointer
+
+(define-type-method alien-type ((type pointer))
+ (declare (ignore type))
+ #+(or cmu sbcl) 'system-area-pointer
+ #+clisp 'ffi:c-pointer)
+
+(define-type-method size-of ((type pointer) &key (inlined t))
+ (assert-inlined type inlined)
+ #+sbcl (sb-sizeof 'sb-alien:system-area-pointer)
+ #+clisp (ffi:sizeof 'ffi:c-pointer)
+ #-(or sbcl clisp) 4)
+
+(define-type-method to-alien-form ((type pointer) form &optional copy-p)
+ (declare (ignore type copy-p))
+ form)
+
+(define-type-method to-alien-function ((type pointer) &optional copy-p)
+ (declare (ignore type copy-p))
+ #'identity)
+
+(define-type-method from-alien-form ((type pointer) form &key ref)
+ (declare (ignore type ref))
+ form)
+
+(define-type-method from-alien-function ((type pointer) &key ref)
+ (declare (ignore type ref))
+ #'identity)
+
+(define-type-method writer-function ((type pointer) &key temp (inlined t))
+ (declare (ignore temp))
+ (assert-inlined type inlined)
+ #'(setf ref-pointer))
+
+(define-type-method reader-function ((type pointer) &key ref (inlined t))
+ (declare (ignore ref))
+ (assert-inlined type inlined)
+ #'ref-pointer)
+
+
+(define-type-method alien-type ((type null))
+ (declare (ignore type))
+ (alien-type 'pointer))
+
+(define-type-method size-of ((type null) &key (inlined t))
+ (assert-inlined type inlined)
+ (size-of 'pointer))
+
+(define-type-method to-alien-form ((type null) null &optional copy-p)
+ (declare (ignore type copy-p))
+ `(progn ,null (make-pointer 0)))
+
+(define-type-method to-alien-function ((type null) &optional copy-p)
+ (declare (ignore type copy-p))
+ #'(lambda (null)
+ (declare (ignore null))
+ (make-pointer 0)))
+
+
+(define-type-method alien-type ((type nil))
+ (declare (ignore type))
+ #+(or cmu sbcl) 'void
+ #+clisp nil)
+
+(define-type-method from-alien-form ((type nil) form &key ref)
+ (declare (ignore type ref))
+ form)
+
+(define-type-method from-alien-function ((type nil) &key ref)
+ (declare (ignore type ref))
+ #'(lambda (value)
+ (declare (ignore value))
+ (values)))
+
+(define-type-method to-alien-form ((type nil) form &optional copy-p)
+ (declare (ignore type copy-p))
+ form)
+
+
+
+;;; Callbacks
+
+(define-type-method alien-type ((type callback))
+ (declare (ignore type))
+ (alien-type 'pointer))
+
+(define-type-method to-alien-form ((type callback) callback &optional copy-p)
+ (declare (ignore type copy-p))
+ `(callback-address ,callback))
+
+
+
+;;; Copy-of
+
+(define-type-method from-alien-form ((type copy-of) form &key (ref :copy))
+ (if (eq ref :copy)
+ (from-alien-form (second (type-expand-to 'copy-of type)) form :ref ref)
+ (error "Keyword arg :REF to FROM-ALIEN-FORM should be :COPY for type ~A. It was give ~A" type ref)))
+
+(define-type-method from-alien-function ((type copy-of) &key (ref :copy))
+ (if (eq ref :copy)
+ (from-alien-function (second (type-expand-to 'copy-of type)) :ref ref)
+ (error "Keyword arg :REF to FROM-ALIEN-FORM should be :COPY for type ~A. It was give ~A" type ref)))
+
+(define-type-method to-alien-form ((type copy-of) form &optional (copy-p t))
+ (if copy-p
+ (to-alien-form (second (type-expand-to 'copy-of type)) form t)
+ (error "COPY-P argument to TO-ALIEN-FORM should always be non NIL for type ~A" type)))
+
+(define-type-method to-alien-function ((type copy-of) &optional (copy-p t))
+ (if copy-p
+ (to-alien-function (second (type-expand-to 'copy-of type)) t)
+ (error "COPY-P argument to TO-ALIEN-FUNCTION should always be non NIL for type ~A" type)))
+
+(define-type-method reader-function ((type copy-of) &key (ref :read) (inlined nil inlined-p))
+ (if inlined-p
+ (reader-function (second (type-expand-to 'copy-of type))
+ :ref (if (eq ref :get) :read ref) :inlined inlined)
+ (reader-function (second (type-expand-to 'copy-of type))
+ :ref (if (eq ref :get) :read ref))))
+
+(define-type-method destroy-function ((type copy-of) &key temp inlined)
+ (declare (ignore type temp inlined))
+ #'(lambda (location &optional offset)
+ (declare (ignore location offset))))
+
+(define-type-method copy-function ((type copy-of) &key (inlined nil inlined-p))
+ (let ((size (if inlined-p
+ (size-of type :inlined inlined)
+ (size-of type))))
+ #'(lambda (from to &optional (offset 0))
+ (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
+
+
+
+;;; Static
+
+(define-type-method from-alien-form ((type static) form &key (ref :static))
+ (if (eq ref :static)
+ (from-alien-form (second (type-expand-to 'static type)) form :ref ref)
+ (error "Keyword arg :REF to FROM-ALIEN-FORM should be :STATIC for type ~A. It was give ~A" type ref)))
+
+(define-type-method from-alien-function ((type static) &key (ref :static))
+ (if (eq ref :static)
+ (from-alien-function (second (type-expand-to 'static type)) :ref ref)
+ (error "Keyword arg :REF to FROM-ALIEN-FORM should be :STATIC for type ~A. It was give ~A" type ref)))
+
+(define-type-method to-alien-function ((type static) &optional copy-p)
+ (if (not copy-p)
+ (to-alien-function (second (type-expand-to 'static type)) t)
+ (error "COPY-P argument to TO-ALIEN-FUNCTION should always be NIL for type ~A" type)))
+
+(define-type-method to-alien-form ((type static) &optional copy-p)
+ (if (not copy-p)
+ (to-alien-function (second (type-expand-to 'static type)) t)
+ (error "COPY-P argument to TO-ALIEN-FUNCTION should always be NIL for type ~A" type)))
+
+(define-type-method reader-function ((type static) &key (ref :read) (inlined nil inlined-p))
+ (if inlined-p
+ (reader-function (second (type-expand-to 'static type))
+ :ref (if (eq ref :get) :read ref) :inlined inlined)
+ (reader-function (second (type-expand-to 'static type))
+ :ref (if (eq ref :get) :read ref))))
+
+(define-type-method writer-function ((type static) &key temp inlined)
+ (declare (ignore type temp inlined))
+ (error "Can't overwrite a static (const) reference"))
+
+(define-type-method destroy-function ((type static) &key temp inlined)
+ (declare (ignore type temp inlined))
+ #'(lambda (location &optional offset)
+ (declare (ignore location offset))))
+
+(define-type-method copy-function ((type static) &key (inlined nil inlined-p))
+ (let ((size (if inlined-p
+ (size-of type :inlined inlined)
+ (size-of type))))
+ #'(lambda (from to &optional (offset 0))
+ (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
+
+
+
+;;; Pseudo type for inlining of types which are not inlined by default
+
+(define-type-method size-of ((type inlined) &key (inlined t))
+ (assert-inlined type inlined)
+ (size-of (second (type-expand-to 'inlined type)) :inlined t))
+
+(define-type-method reader-function ((type inlined) &key (ref :read) (inlined t))
+ (assert-inlined type inlined)
+ (reader-function (second (type-expand-to 'inlined type)) :ref ref :inlined t))
+
+(define-type-method writer-function ((type inlined) &key temp (inlined t))
+ (assert-inlined type inlined)
+ (writer-function (second (type-expand-to 'inlined type)) :temp temp :inlined t))
+
+(define-type-method destroy-function ((type inlined) &key temp (inlined t))
+ (assert-inlined type inlined)
+ (destroy-function (second (type-expand-to 'inlined type)) :temp temp :inlined t))
+
+(define-type-method copy-function ((type inlined) &key (inlined t))
+ (assert-inlined type inlined)
+ (copy-function (second (type-expand-to 'inlined type)) :inlined t))
--- /dev/null
+;; Common Lisp bindings for GTK+ v2.x
+;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
+;;
+;; 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: interface.lisp,v 1.1 2006-04-25 20:36:05 espen Exp $
+
+(in-package "GFFI")
+
+
+;;;; Foreign function call interface
+
+(defvar *package-prefix* nil)
+
+(defun set-package-prefix (prefix &optional (package *package*))
+ (let ((package (find-package package)))
+ (setq *package-prefix* (delete package *package-prefix* :key #'car))
+ (push (cons package prefix) *package-prefix*))
+ prefix)
+
+(defun package-prefix (&optional (package *package*))
+ (let ((package (find-package package)))
+ (or
+ (cdr (assoc package *package-prefix*))
+ (substitute #\_ #\- (string-downcase (package-name package))))))
+
+(defun find-prefix-package (prefix)
+ (or
+ (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=))
+ (find-package (string-upcase prefix))))
+
+(defmacro use-prefix (prefix &optional (package *package*))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (set-package-prefix ,prefix ,package)))
+
+
+(defun default-alien-fname (lisp-name)
+ (let* ((name (substitute #\_ #\- (string-downcase lisp-name)))
+ (stripped-name
+ (cond
+ ((and
+ (char= (char name 0) #\%)
+ (string= "_p" name :start2 (- (length name) 2)))
+ (subseq name 1 (- (length name) 2)))
+ ((char= (char name 0) #\%)
+ (subseq name 1))
+ ((string= "_p" name :start2 (- (length name) 2))
+ (subseq name 0 (- (length name) 2)))
+ (name)))
+ (prefix (package-prefix *package*)))
+ (if (or (not prefix) (string= prefix ""))
+ stripped-name
+ (format nil "~A_~A" prefix stripped-name))))
+
+(defun default-alien-type-name (type-name)
+ (let ((prefix (package-prefix *package*)))
+ (apply
+ #'concatenate
+ 'string
+ (mapcar
+ #'string-capitalize
+ (cons prefix (split-string (symbol-name type-name) :delimiter #\-))))))
+
+(defun default-type-name (alien-name)
+ (let ((parts
+ (mapcar
+ #'string-upcase
+ (split-string-if alien-name #'upper-case-p))))
+ (intern
+ (concatenate-strings (rest parts) #\-)
+ (find-prefix-package (first parts)))))
+
+
+(defun in-arg-p (style)
+ (find style '(:in :in/out :in/return :in-out :return)))
+
+(defun out-arg-p (style)
+ (find style '(:out :in/out :in-out)))
+
+(defun return-arg-p (style)
+ (find style '(:in/return :return)))
+
+(defmacro defbinding (name lambda-list return-type &rest args)
+ (multiple-value-bind (lisp-name c-name)
+ (if (atom name)
+ (values name (default-alien-fname name))
+ (values-list name))
+
+ (let* ((lambda-list-supplied-p lambda-list)
+ (lambda-list (unless (equal lambda-list '(nil)) lambda-list))
+ (aux-vars ())
+ (doc-string (when (stringp (first args)) (pop args)))
+ (parsed-args
+ (mapcar
+ #'(lambda (arg)
+ (destructuring-bind
+ (expr type &optional (style :in) (out-type type)) arg
+ (cond
+ ((find style '(:in-out :return))
+ (warn "Deprecated argument style: ~S" style))
+ ((not (find style '(:in :out :in/out :in/return)))
+ (error "Bogus argument style: ~S" style)))
+ (when (and
+ (not lambda-list-supplied-p)
+ (namep expr) (in-arg-p style))
+ (push expr lambda-list))
+ (let ((aux (unless (or (not (in-arg-p style)) (namep expr))
+ (gensym))))
+ (when aux
+ (push `(,aux ,expr) aux-vars))
+ (list
+ (cond
+ ((and (namep expr) (not (in-arg-p style))) expr)
+ ((namep expr) (make-symbol (string expr)))
+ ((gensym)))
+ (or aux expr) type style out-type))))
+ args)))
+
+ (%defbinding c-name lisp-name
+ (if lambda-list-supplied-p lambda-list (nreverse lambda-list))
+ aux-vars return-type doc-string parsed-args))))
+
+
+#+(or cmu sbcl)
+(defun foreign-funcall (cname args return-type)
+ (let ((fparams (loop
+ for (var expr type style out-type) in args
+ collect (if (out-arg-p style)
+ `(addr ,var)
+ var)))
+ (ftypes (loop
+ for (var expr type style out-type) in args
+ collect (if (out-arg-p style)
+ `(* ,(alien-type out-type))
+ (alien-type out-type))))
+ (fname (make-symbol cname)))
+ `(with-alien ((,fname (function ,(alien-type return-type) ,@ftypes) :extern ,cname))
+ (alien-funcall ,fname ,@fparams))))
+
+#+clisp
+(defun foreign-funcall (cname args return-type)
+ (let* ((fparams (loop
+ for (var expr type style out-type) in args
+ collect (if (out-arg-p style)
+ `(ffi:c-var-address ,var)
+ var)))
+ (fargs (loop
+ for (var expr type style out-type) in args
+ collect (list var (if (out-arg-p style)
+ 'ffi:c-pointer
+ (alien-type out-type)))))
+ (c-function `(ffi:c-function
+ (:arguments ,@fargs)
+ (:return-type ,(alien-type return-type))
+ (:language :stdc))))
+ `(funcall
+ (load-time-value
+ (ffi::foreign-library-function ,cname (ffi::foreign-library :default)
+ nil (ffi:parse-c-type ',c-function)))
+ ,@fparams)))
+
+
+;; TODO: check if in and out types (if different) translates to same
+;; alien type
+(defun %defbinding (cname lisp-name lambda-list aux-vars return-type doc args)
+ (let ((out (loop
+ for (var expr type style out-type) in args
+ when (or (out-arg-p style) (return-arg-p style))
+ collect (from-alien-form out-type var)))
+ (fcall (from-alien-form return-type
+ (foreign-funcall cname args return-type))))
+
+ (labels ((create-wrapper (args body)
+ (if args
+ (destructuring-bind (var expr type style out-type) (first args)
+ (declare (ignore out-type))
+ (alien-arg-wrapper type var expr style
+ (create-wrapper (rest args) body)))
+ body)))
+ `(defun ,lisp-name ,lambda-list
+ ,doc
+ (let ,aux-vars
+ ,(if return-type
+ (create-wrapper args `(values ,fcall ,@out))
+ (create-wrapper args `(progn ,fcall (values ,@out)))))))))
+
+
+
+;;;; Dynamic (runtime) bindings
+
+(defun mkbinding (name return-type &rest arg-types)
+ #+cmu(declare (optimize (inhibit-warnings 3)))
+ #+sbcl(declare (muffle-conditions compiler-note))
+ (let* ((c-function
+ #+(or cmu sbcl)
+ `(function ,@(mapcar #'alien-type (cons return-type arg-types)))
+ #+clisp
+ `(ffi:c-function
+ (:arguments ,@(mapcar
+ #'(lambda (type)
+ (list (gensym) (alien-type type)))
+ arg-types))
+ (:return-type ,(alien-type return-type))
+ (:language :stdc)))
+ (foreign
+ #+(or cmu sbcl)
+ (handler-bind (#+sbcl(compiler-note #'(lambda (condition)
+ (declare (ignore condition))
+ (muffle-warning))))
+ (%heap-alien
+ (make-heap-alien-info
+ :type (parse-alien-type c-function #+sbcl nil)
+ :sap-form (let ((address (foreign-symbol-address name)))
+ (etypecase address
+ (integer (int-sap address))
+ (system-area-pointer address))))))
+ #+clisp
+ (ffi::foreign-library-function name
+ (ffi::foreign-library :default)
+ nil (ffi:parse-c-type c-function)))
+ (return-value-translator (from-alien-function return-type)))
+ (multiple-value-bind (arg-translators cleanup-funcs)
+ (let ((translator/cleanup-pairs
+ (mapcar
+ #'(lambda (type)
+ (multiple-value-list (to-alien-function type)))
+ arg-types)))
+ (values
+ (mapcar #'first translator/cleanup-pairs)
+ (mapcar #'second translator/cleanup-pairs)))
+ #'(lambda (&rest args)
+ (let ((translated-args (mapcar #'funcall arg-translators args)))
+ (prog1
+ (funcall return-value-translator
+ #+(or cmu sbcl)(apply #'alien-funcall foreign translated-args)
+ #+clisp(apply foreign translated-args))
+ (mapc
+ #'(lambda (cleanup arg translated-arg)
+ (when cleanup
+ (funcall cleanup arg translated-arg)))
+ cleanup-funcs args translated-args)))))))
+
+
+
+;;;; C Callbacks
+
+(defun callback-body (args return-type body)
+ (labels ((create-wrappers (args body)
+ (if args
+ (destructuring-bind (var type) (first args)
+ (callback-wrapper type var var
+ (create-wrappers (rest args) body)))
+ body))
+ (create-body (args body)
+ (to-alien-form return-type
+ (create-wrappers args `(progn ,@body)))))
+ (if (and (consp (first body)) (eq (caar body) 'declare))
+ (let ((ignored (loop
+ for declaration in (cdar body)
+ when (eq (first declaration) 'ignore)
+ nconc (rest declaration))))
+ `(,(first body)
+ ,(create-body
+ (remove-if #'(lambda (arg)
+ (find (first arg) ignored))
+ args)
+ (rest body))))
+ (list (create-body args body)))))
+
+
+#+(or cmu sbcl)
+(defmacro define-callback (name return-type args &body body)
+ (let ((define-callback
+ #+cmu'alien:def-callback
+ #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback
+ #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function))
+ `(progn
+ #+cmu(defparameter ,name nil)
+ (,define-callback ,name
+ #+(and sbcl alien-callbacks) ,(alien-type return-type)
+ (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type)
+ ,@(loop
+ for (name type) in args
+ collect `(,name ,(alien-type type))))
+ ,@(callback-body args return-type body)))))
+
+#+(or cmu sbcl)
+(defun callback-address (callback)
+ #+cmu(alien::callback-trampoline callback)
+ #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback)
+ #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback))
+
+#+sbcl
+(deftype callback ()
+ #-alien-callbacks'sb-alien:alien-function
+ #+alien-callbacks'sb-alien:alien)
+
+
+;;; The callback code for CLISP is based on code from CFFI
+;;; Copyright (C) 2005, James Bielman <jamesjb@jamesjb.com>
+;;; (C) 2005, Joerg Hoehle <hoehle@users.sourceforge.net>
+
+
+;;; *CALLBACKS* contains the callbacks defined by the %DEFCALLBACK
+;;; macro. The symbol naming the callback is the key, and the value
+;;; is a list containing a Lisp function, the parsed CLISP FFI type of
+;;; the callback, and a saved pointer that should not persist across
+;;; saved images.
+#+clisp
+(progn
+ (defvar *callbacks* (make-hash-table))
+
+ ;;; Return a CLISP FFI function type for a CFFI callback function
+ ;;; given a return type and list of argument names and types.
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun callback-type (return-type arg-names arg-types)
+ (ffi:parse-c-type
+ `(ffi:c-function
+ (:arguments ,@(mapcar (lambda (sym type)
+ (list sym (alien-type type)))
+ arg-names arg-types))
+ (:return-type ,(alien-type return-type))
+ (:language :stdc)))))
+
+ ;;; Register and create a callback function.
+ (defun register-callback (name function parsed-type)
+ (setf (gethash name *callbacks*)
+ (list function parsed-type
+ (ffi:with-foreign-object (ptr 'ffi:c-pointer)
+ ;; Create callback by converting Lisp function to foreign
+ (setf (ffi:memory-as ptr parsed-type) function)
+ (ffi:foreign-value ptr)))))
+
+ ;;; Restore all saved callback pointers when restarting the Lisp
+ ;;; image. This is pushed onto CUSTOM:*INIT-HOOKS*.
+ ;;; Needs clisp > 2.35, bugfix 2005-09-29
+ (defun restore-callback-pointers ()
+ (maphash
+ (lambda (name list)
+ (register-callback name (first list) (second list)))
+ *callbacks*))
+
+ ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run
+ ;;; when an image is restarted.
+ (eval-when (:load-toplevel :execute)
+ (pushnew 'restore-callback-pointers custom:*init-hooks*))
+
+ ;;; Define a callback function NAME to run BODY with arguments
+ ;;; ARG-NAMES translated according to ARG-TYPES and the return type
+ ;;; translated according to RETTYPE. Obtain a pointer that can be
+ ;;; passed to C code for this callback by calling %CALLBACK.
+ (defmacro define-callback (name return-type args &body body)
+ (let ((arg-names (mapcar #'first args))
+ (arg-types (mapcar #'second args)))
+ `(progn
+ (defvar ,name ',name)
+ (register-callback ',name
+ (lambda ,arg-names ,@(callback-body args return-type body))
+ ,(callback-type return-type arg-names arg-types)))))
+
+ ;;; Look up the name of a callback and return a pointer that can be
+ ;;; passed to a C function. Signals an error if no callback is
+ ;;; defined called NAME.
+ (defun callback-address (name)
+ (multiple-value-bind (list winp) (gethash name *callbacks*)
+ (unless winp
+ (error "Undefined callback: ~S" name))
+ (third list)))
+
+ (deftype callback () 'symbol))
+
+
+
+;;;; Type expansion
+
+(defun type-expand-1 (form)
+ #+(or cmu sbcl)
+ (let ((def (cond ((symbolp form)
+ #+cmu(kernel::info type expander form)
+ #+sbcl(sb-impl::info :type :expander form))
+ ((and (consp form) (symbolp (car form)))
+ #+cmu(kernel::info type expander (car form))
+ #+sbcl(sb-impl::info :type :expander (car form)))
+ (t nil))))
+ (if def
+ (values (funcall def (if (consp form) form (list form))) t)
+ (values form nil)))
+ #+clisp(ext:type-expand form t))
+
+(defun type-expand-to (type form)
+ (labels ((expand (form0)
+ (if (eq (first (mklist form0)) type)
+ form0
+ (multiple-value-bind (expanded-form expanded-p)
+ (type-expand-1 form0)
+ (if expanded-p
+ (expand expanded-form)
+ (error "~A can not be expanded to ~A" form type))))))
+ (expand form)))
+
+
+
+;;;; Type methods
+
+(defun find-next-type-method (name type-spec &optional (error-p t))
+ (let ((type-methods (get name 'type-methods)))
+ (labels ((search-method-in-cpl-order (classes)
+ (when classes
+ (or
+ (gethash (class-name (first classes)) type-methods)
+ (search-method-in-cpl-order (rest classes)))))
+ (lookup-method (type-spec)
+ (if (and (symbolp type-spec) (find-class type-spec nil))
+ (let ((class (find-class type-spec)))
+ #+clisp
+ (unless (class-finalized-p class)
+ (finalize-inheritance class))
+ (search-method-in-cpl-order
+ (rest (class-precedence-list class))))
+ (multiple-value-bind (expanded-type expanded-p)
+ (type-expand-1 type-spec)
+ (when expanded-p
+ (or
+ (let ((specifier (etypecase expanded-type
+ (symbol expanded-type)
+ (list (first expanded-type)))))
+ (gethash specifier type-methods))
+ (lookup-method expanded-type))))))
+ (search-built-in-type-hierarchy (sub-tree)
+ (when (subtypep type-spec (first sub-tree))
+ (or
+ (search-nodes (cddr sub-tree))
+ (second sub-tree))))
+ (search-nodes (nodes)
+ (loop
+ for node in nodes
+ as method = (search-built-in-type-hierarchy node)
+ until method
+ finally (return method))))
+ (or
+ (lookup-method type-spec)
+ ;; This is to handle unexpandable types whichs doesn't name a
+ ;; class. It may cause infinite loops with illegal
+ ;; call-next-method calls
+ (unless (and (symbolp type-spec) (find-class type-spec nil))
+ (search-nodes (get name 'built-in-type-hierarchy)))
+ (when error-p
+ (error "No next type method ~A for type specifier ~A"
+ name type-spec))))))
+
+(defun find-applicable-type-method (name type-spec &optional (error-p t))
+ (let ((type-methods (get name 'type-methods))
+ (specifier (if (atom type-spec)
+ type-spec
+ (first type-spec))))
+ (or
+ (gethash specifier type-methods)
+ (find-next-type-method name type-spec nil)
+ (when error-p
+ (error
+ "No applicable type method for ~A when call width type specifier ~A"
+ name type-spec)))))
+
+(defun insert-type-in-hierarchy (specifier function nodes)
+ (cond
+ ((let ((node (find specifier nodes :key #'first)))
+ (when node
+ (setf (second node) function)
+ nodes)))
+ ((let ((node
+ (find-if
+ #'(lambda (node)
+ (subtypep specifier (first node)))
+ nodes)))
+ (when node
+ (setf (cddr node)
+ (insert-type-in-hierarchy specifier function (cddr node)))
+ nodes)))
+ ((let ((sub-nodes (remove-if-not
+ #'(lambda (node)
+ (subtypep (first node) specifier))
+ nodes)))
+ (cons
+ (list* specifier function sub-nodes)
+ (nset-difference nodes sub-nodes))))))
+
+(defun add-type-method (name specifier function)
+ (setf (gethash specifier (get name 'type-methods)) function)
+ (when (typep (find-class specifier nil) 'built-in-class)
+ (setf (get name 'built-in-type-hierarchy)
+ (insert-type-in-hierarchy specifier function
+ (get name 'built-in-type-hierarchy)))))
+
+
+(defmacro define-type-generic (name lambda-list &optional documentation)
+ (let ((type-spec (first lambda-list)))
+ (if (or
+ (not lambda-list)
+ (find type-spec '(&optional &key &rest &allow-other-keys)))
+ (error "A type generic needs at least one required argument")
+ `(progn
+ (unless (get ',name 'type-methods)
+ (setf (get ',name 'type-methods) (make-hash-table))
+ (setf (get ',name 'built-in-type-hierarchy) ()))
+ ,(if (intersection '(&optional &key &rest &allow-other-keys) lambda-list)
+ (let ((args (make-symbol "ARGS")))
+ `(defun ,name (,type-spec &rest ,args)
+ ,documentation
+ (apply
+ (find-applicable-type-method ',name ,type-spec)
+ ,type-spec ,args)))
+ `(defun ,name ,lambda-list
+ ,documentation
+ (funcall
+ (find-applicable-type-method ',name ,type-spec)
+ ,@lambda-list)))))))
+
+
+(defmacro define-type-method (name lambda-list &body body)
+ (let ((specifier (cadar lambda-list))
+ (args (make-symbol "ARGS")))
+ `(progn
+ (add-type-method ',name ',specifier
+ #'(lambda (&rest ,args)
+ (flet ((call-next-method (&rest args)
+ (let ((next-method (find-next-type-method ',name ',specifier)))
+ (apply next-method (or args ,args)))))
+ (destructuring-bind (,(caar lambda-list) ,@(rest lambda-list)) ,args
+ ,@body))))
+ ',name)))
+
+
+;;; Rules for auto-exporting symbols
+
+(defexport defbinding (name &rest args)
+ (declare (ignore args))
+ (if (symbolp name)
+ name
+ (first name)))
+
+(defexport define-type-generic (name &rest args)
+ (declare (ignore args))
+ name)
~mdw / clg / commitdiff