;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: atk.lisp,v 1.3 2004/10/31 11:44:45 espen Exp $
+;; $Id: atk.lisp,v 1.4 2004/11/06 21:39:57 espen Exp $
(in-package "ATK")
(eval-when (:compile-toplevel :load-toplevel :execute)
- (init-types-in-library "libatk-1.0.so"))
+ (init-types-in-library
+ #.(concatenate 'string (pkg-config:pkg-variable "atk" "libdir")
+ "/libatk-1.0.so") :prefix "atk_"))
(define-types-by-introspection "Atk")
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gdk.lisp,v 1.10 2004/10/31 11:51:08 espen Exp $
+;; $Id: gdk.lisp,v 1.11 2004/11/06 21:39:58 espen Exp $
(in-package "GDK")
;;; Display
-(defbinding %display-manager-get () display-manager)
+(defbinding (display-manager "gdk_display_manager_get") () display-manager)
+
(defbinding (display-set-default "gdk_display_manager_set_default_display")
(display) nil
- ((%display-manager-get) display-manager)
+ ((display-manager) display-manager)
(display display))
(defbinding display-get-default () display)
;;; Cursor
-(deftype-method alien-ref cursor (type-spec)
- (declare (ignore type-spec))
- '%cursor-ref)
-
-(deftype-method alien-unref cursor (type-spec)
- (declare (ignore type-spec))
- '%cursor-unref)
-
-
(defbinding cursor-new () cursor
(cursor-type cursor-type))
(x int) (y int))
(defbinding %cursor-ref () pointer
- (cursor (or cursor pointer)))
+ (location pointer))
(defbinding %cursor-unref () nil
- (cursor (or cursor pointer)))
+ (location pointer))
+
+(defmethod reference-foreign ((class (eql (find-class 'cursor))) location)
+ (declare (ignore class))
+ (%cursor-ref location))
+
+(defmethod unreference-foreign ((class (eql (find-class 'cursor))) location)
+ (declare (ignore class))
+ (%cursor-unref location))
+
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gdkevents.lisp,v 1.4 2004/10/31 11:53:30 espen Exp $
+;; $Id: gdkevents.lisp,v 1.5 2004/11/06 21:39:58 espen Exp $
(in-package "GDK")
(defvar *event-classes* (make-hash-table))
-(defun %type-of-event (location)
- (class-name
- (gethash
- (funcall (intern-reader-function 'event-type) location 0)
- *event-classes*)))
-
(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass event (boxed)
((%type
(call-next-method)
(setf (slot-value event '%type) (event-class-type (class-of event))))
-(deftype-method translate-from-alien
- event (type-spec location &optional weak-ref)
- (declare (ignore type-spec))
- `(let ((location ,location))
- (unless (null-pointer-p location)
- (ensure-proxy-instance (%type-of-event location) location ,weak-ref))))
-
;;;; Metaclass for event classes
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass event-class (proxy-class)
+ (defclass event-class (boxed-class)
((event-type :reader event-class-type)))
+ (defmethod validate-superclass ((class event-class) (super standard-class))
+ (subtypep (class-name super) 'event)))
+
+
+(defmethod shared-initialize ((class event-class) names &key name type)
+ (call-next-method)
+ (setf (slot-value class 'event-type) (first type))
+ (setf (gethash (first type) *event-classes*) class)
+ (let ((class-name (or name (class-name class))))
+ (register-type class-name 'event)))
- (defmethod shared-initialize ((class event-class) names &key name type)
- (call-next-method)
- (setf (slot-value class 'event-type) (first type))
- (setf (gethash (first type) *event-classes*) class)
- (let ((class-name (or name (class-name class))))
- (register-type class-name 'event)))
-
+(let ((reader (reader-function 'event-type)))
+ (defun %event-class (location)
+ (gethash (funcall reader location 0) *event-classes*)))
- (defmethod validate-superclass
- ((class event-class) (super pcl::standard-class))
- (subtypep (class-name super) 'event)))
+(defmethod ensure-proxy-instance ((class event-class) location)
+ (declare (ignore class))
+ (let ((class (%event-class location)))
+ (make-instance class :location location)))
;;;;
:accessor event-time
:initarg :time
:type (unsigned 32)))
- (:metaclass proxy-class))
+ (:metaclass event-class))
(defclass delete-event (event)
()
(:metaclass event-class)
(:type :delete))
+
(defclass destroy-event (event)
()
(:metaclass event-class)
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gdktypes.lisp,v 1.7 2002/03/19 19:06:22 espen Exp $
+;; $Id: gdktypes.lisp,v 1.8 2004/11/06 21:39:58 espen Exp $
(in-package "GDK")
(eval-when (:compile-toplevel :load-toplevel :execute)
- (init-types-in-library "libgdk-x11-2.0.so")
- (init-types-in-library "libgdk_pixbuf-2.0.so"))
+ (init-types-in-library #.(concatenate 'string
+ (pkg-config:pkg-variable "gtk+-2.0" "libdir")
+ "/libgdk-x11-2.0.so") :prefix "gdk_")
+ (init-types-in-library #.(concatenate 'string
+ (pkg-config:pkg-variable "gtk+-2.0" "libdir")
+ "/libgdk-x11-2.0.so") :prefix "_gdk_")
+ (init-types-in-library #.(concatenate 'string
+ (pkg-config:pkg-variable "gtk+-2.0" "libdir")
+ "/libgdk_pixbuf-2.0.so") :prefix "gdk_"))
+
(defclass color (boxed)
((pixel
:accessor cursor-type
:initarg :type
:type cursor-type))
- (:metaclass proxy-class)
- (:copy %cursor-copy)
- (:free %cursor-free))
+ (:metaclass struct-class))
(defclass device (struct)
()
- (:metaclass proxy-class))
-
+ (:metaclass struct-class))
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: defpackage.lisp,v 1.1 2004/10/27 14:48:00 espen Exp $
+;; $Id: defpackage.lisp,v 1.2 2004/11/06 21:39:58 espen Exp $
;(export 'kernel::type-expand-1 "KERNEL")
(defpackage "GLIB"
- (:use "ALIEN" "C-CALL" "SYSTEM" "COMMON-LISP" "PCL" "AUTOEXPORT"
- "GLIB-SYSTEM")
- (;:shadowing-
- :import-from "PCL"
+ (:use "ALIEN" "SYSTEM" "COMMON-LISP" "PCL" "AUTOEXPORT")
+ (:import-from "PCL"
"LOCATION" "ALLOCATION" "DIRECT-SLOTS"
"READER-FUNCTION" "WRITER-FUNCTION" "BOUNDP-FUNCTION"
"INITIALIZE-INTERNAL-SLOT-FUNCTIONS" "COMPUTE-SLOT-ACCESSOR-INFO"
"COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS"
- #:initialize-internal-slot-gfs)
- ; (:import-from "KERNEL" "TYPE-EXPAND-1")
- (:export #:load-shared-library)
+ "INITIALIZE-INTERNAL-SLOT-GFS")
(:export "DEFTYPE-METHOD" "TRANSLATE-TYPE-SPEC" "TRANSLATE-TO-ALIEN"
"TRANSLATE-FROM-ALIEN" "CLEANUP-ALIEN" "UNREFERENCE-ALIEN"
"SIZE-OF")
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: ffi.lisp,v 1.1 2004/10/27 14:46:01 espen Exp $
+;; $Id: ffi.lisp,v 1.2 2004/11/06 21:39:58 espen Exp $
(in-package "GLIB")
-;;;; Type methods
-
-(defvar *type-methods* (make-hash-table))
-
-(defun ensure-type-method-fun (fname)
- (unless (fboundp fname)
- (setf
- (symbol-function fname)
- #'(lambda (type-spec &rest args)
- (apply
- (find-applicable-type-method type-spec fname) type-spec args)))))
-
-(defmacro define-type-method-fun (fname lambda-list)
- (declare (ignore lambda-list))
- `(defun ,fname (type-spec &rest args)
- (apply
- (find-applicable-type-method type-spec ',fname) type-spec args)))
-
-
-(defun ensure-type-name (type)
- (etypecase type
- (symbol type)
- (pcl::class (class-name type))))
-
-(defun add-type-method (type fname function)
- (push
- (cons fname function)
- (gethash (ensure-type-name type) *type-methods*)))
-
-(defun find-type-method (type fname)
- (cdr (assoc fname (gethash (ensure-type-name type) *type-methods*))))
-
-(defun find-applicable-type-method (type-spec fname &optional (error t))
- (flet ((find-superclass-method (class)
- (when (and class (class-finalized-p class))
-; (unless (class-finalized-p class)
-; (finalize-inheritance class))
- (dolist (super (cdr (pcl::class-precedence-list class)))
- (return-if (find-type-method super fname)))))
- (find-expanded-type-method (type-spec)
- (multiple-value-bind (expanded-type-spec expanded-p)
- (type-expand-1 type-spec)
- (cond
- (expanded-p
- (find-applicable-type-method expanded-type-spec fname nil))
- ((neq type-spec t)
- (find-applicable-type-method t fname nil))))))
-
- (or
- (typecase type-spec
- (pcl::class
- (or
- (find-type-method type-spec fname)
- (find-superclass-method type-spec)))
- (symbol
- (or
- (find-type-method type-spec fname)
- (find-expanded-type-method type-spec)
- (find-superclass-method (find-class type-spec nil))))
- (cons
- (or
- (find-type-method (first type-spec) fname)
- (find-expanded-type-method type-spec)))
- (t
- (error "Invalid type specifier ~A" type-spec)))
- (and
- error
- (error
- "No applicable method for ~A when called with type specifier ~A"
- fname type-spec)))))
-
-(defmacro deftype-method (fname type lambda-list &body body)
- `(progn
- (ensure-type-method-fun ',fname)
- (add-type-method ',type ',fname #'(lambda ,lambda-list ,@body))
- ',fname))
-
-;; To make the compiler happy
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (define-type-method-fun translate-type-spec (type-spec))
- (define-type-method-fun size-of (type-spec))
- (define-type-method-fun translate-to-alien (type-spec expr &optional weak-ref))
- (define-type-method-fun translate-from-alien (type-spec expr &optional weak-ref))
- (define-type-method-fun cleanup-alien (type-spec sap &otional weak-ref))
- (define-type-method-fun unreference-alien (type-spec sap)))
-
-
-;;;;
-
-(defvar *type-function-cache* (make-hash-table :test #'equal))
-
-(defun get-cached-function (type-spec fname)
- (cdr (assoc fname (gethash type-spec *type-function-cache*))))
-
-(defun set-cached-function (type-spec fname function)
- (push (cons fname function) (gethash type-spec *type-function-cache*))
- function)
-
-
-(defun intern-argument-translator (type-spec)
- (or
- (get-cached-function type-spec 'argument-translator)
- (set-cached-function type-spec 'argument-translator
- (compile
- nil
- `(lambda (object)
- (declare (ignorable object))
- ,(translate-to-alien type-spec 'object t))))))
-
-(defun intern-return-value-translator (type-spec)
- (or
- (get-cached-function type-spec 'return-value-translator)
- (set-cached-function type-spec 'return-value-translator
- (compile
- nil
- `(lambda (alien)
- (declare (ignorable alien))
- ,(translate-from-alien type-spec 'alien nil))))))
-
-(defun intern-cleanup-function (type-spec)
- (or
- (get-cached-function type-spec 'cleanup-function)
- (set-cached-function type-spec 'cleanup-function
- (compile
- nil
- `(lambda (alien)
- (declare (ignorable alien))
- ,(cleanup-alien type-spec 'alien t))))))
-
-
-
-;; Returns a function to write an object of the specified type
-;; to a memory location
-(defun intern-writer-function (type-spec)
- (or
- (get-cached-function type-spec 'writer-function)
- (set-cached-function type-spec 'writer-function
- (compile
- nil
- `(lambda (value sap offset)
- (declare (ignorable value sap offset))
- (setf
- (,(sap-ref-fname type-spec) sap offset)
- ,(translate-to-alien type-spec 'value nil)))))))
-
-;; Returns a function to read an object of the specified type
-;; from a memory location
-(defun intern-reader-function (type-spec)
- (or
- (get-cached-function type-spec 'reader-function)
- (set-cached-function type-spec 'reader-function
- (compile
- nil
- `(lambda (sap offset)
- (declare (ignorable sap offset))
- ,(translate-from-alien
- type-spec `(,(sap-ref-fname type-spec) sap offset) t))))))
-
-(defun intern-destroy-function (type-spec)
- (if (atomic-type-p type-spec)
- #'(lambda (sap offset)
- (declare (ignore sap offset)))
- (or
- (get-cached-function type-spec 'destroy-function)
- (set-cached-function type-spec 'destroy-function
- (compile
- nil
- `(lambda (sap offset)
- (declare (ignorable sap offset))
- ,(unreference-alien
- type-spec `(,(sap-ref-fname type-spec) sap offset))))))))
-
-
-
;;;;
-(defconstant +bits-per-unit+ 8
- "Number of bits in an addressable unit (byte)")
-
-;; Sizes of fundamental C types in addressable units
+;; Sizes of fundamental C types in bytes (8 bits)
(defconstant +size-of-short+ 2)
(defconstant +size-of-int+ 4)
(defconstant +size-of-long+ 4)
-(defconstant +size-of-sap+ 4)
+(defconstant +size-of-pointer+ 4)
(defconstant +size-of-float+ 4)
(defconstant +size-of-double+ 8)
-(defun sap-ref-unsigned (sap offset)
- (sap-ref-32 sap offset))
-
-(defun sap-ref-signed (sap offset)
- (signed-sap-ref-32 sap offset))
-
-(defun sap-ref-fname (type-spec)
- (let ((alien-type-spec (mklist (translate-type-spec type-spec))))
- (ecase (first alien-type-spec)
- (unsigned
- (ecase (second alien-type-spec)
- (8 'sap-ref-8)
- (16 'sap-ref-16)
- (32 'sap-ref-32)
- (64 'sap-ref-64)))
- (signed
- (ecase (second alien-type-spec)
- (8 'signed-sap-ref-8)
- (16 'signed-sap-ref-16)
- (32 'signed-sap-ref-32)
- (64 'signed-sap-ref-64)))
- (system-area-pointer 'sap-ref-sap)
- (single-float 'sap-ref-single)
- (double-float 'sap-ref-double))))
+;; Sizes of fundamental C types in bits
+(defconstant +bits-of-byte+ 8)
+(defconstant +bits-of-short+ 16)
+(defconstant +bits-of-int+ 32)
+(defconstant +bits-of-long+ 32)
+
+
;;;; Foreign function call interface
(rest parts) #\-) (find-prefix-package (first parts)))))
-(defmacro defbinding (name lambda-list return-type-spec &rest docs/args)
+(defmacro defbinding (name lambda-list return-type &rest docs/args)
(multiple-value-bind (lisp-name c-name)
(if (atom name)
(values name (default-alien-fname name))
(namep expr) (member style '(:in :in-out)))
(push expr lambda-list))
(push
- (list (if (namep expr) (make-symbol (string expr)) (gensym)) expr type style) args)))))
+ (list (if (namep expr)
+ (make-symbol (string expr))
+ (gensym))
+ expr (mklist type) style) args)))))
(%defbinding
c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
- return-type-spec (reverse docs) (reverse args)))))
+ return-type (reverse docs) (reverse args)))))
#+cmu
-(defun %defbinding (foreign-name lisp-name lambda-list
- return-type-spec docs args)
- (ext:collect ((alien-types) (alien-bindings) (alien-parameters)
- (alien-values) (alien-deallocators))
+(defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
+ (ext:collect ((alien-types) (alien-bindings) (alien-parameters)
+ (alien-values) (cleanup-forms))
(dolist (arg args)
- (destructuring-bind (var expr type-spec style) arg
- (let ((declaration (translate-type-spec type-spec))
- (deallocation (cleanup-alien type-spec var t)))
+ (destructuring-bind (var expr type style) arg
+ (let ((declaration (alien-type type))
+ (cleanup (cleanup-form var type)))
+
(cond
((member style '(:out :in-out))
(alien-types `(* ,declaration))
(alien-bindings
`(,var ,declaration
,@(when (eq style :in-out)
- (list (translate-to-alien type-spec expr t)))))
- (alien-values (translate-from-alien type-spec var nil)))
- (deallocation
+ (list (to-alien-form expr type)))))
+ (alien-values (from-alien-form var type)))
+ (cleanup
(alien-types declaration)
(alien-bindings
- `(,var ,declaration ,(translate-to-alien type-spec expr t)))
+ `(,var ,declaration ,(to-alien-form expr type)))
(alien-parameters var)
- (alien-deallocators deallocation))
+ (cleanup-forms cleanup))
(t
(alien-types declaration)
- (alien-parameters (translate-to-alien type-spec expr t)))))))
+ (alien-parameters (to-alien-form expr type)))))))
(let* ((alien-name (make-symbol (string lisp-name)))
(alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters))))
(declare (optimize (ext:inhibit-warnings 3)))
(with-alien ((,alien-name
(function
- ,(translate-type-spec return-type-spec)
+ ,(alien-type return-type)
,@(alien-types))
:extern ,foreign-name)
,@(alien-bindings))
- ,(if return-type-spec
- `(let ((result
- ,(translate-from-alien return-type-spec alien-funcall nil)))
- ,@(alien-deallocators)
- (values result ,@(alien-values)))
+ ,(if return-type
+ `(values
+ (unwind-protect
+ ,(from-alien-form alien-funcall return-type)
+ ,@(cleanup-forms))
+ ,@(alien-values))
`(progn
- ,alien-funcall
- ,@(alien-deallocators)
- (values ,@(alien-values)))))))))
+ (unwind-protect
+ ,alien-funcall
+ ,@(cleanup-forms))
+ (values ,@(alien-values)))))))))
+;;; Creates bindings at runtime
(defun mkbinding (name return-type &rest arg-types)
- (declare (optimize (ext:inhibit-warnings 3)))
- (let* ((ftype
- `(function
- ,@(mapcar #'translate-type-spec (cons return-type arg-types))))
+ (declare (optimize (ext:inhibit-warnings 3)))
+ (let* ((ftype
+ `(function ,@(mapcar #'alien-type (cons return-type arg-types))))
(alien
(alien::%heap-alien
(alien::make-heap-alien-info
:type (alien::parse-alien-type ftype)
:sap-form (system:foreign-symbol-address name :flavor :code))))
- (translate-arguments
- (mapcar #'intern-argument-translator arg-types))
- (translate-return-value (intern-return-value-translator return-type))
- (cleanup-arguments (mapcar #'intern-cleanup-function arg-types)))
-
+ (translate-arguments (mapcar #'to-alien-function arg-types))
+ (translate-return-value (from-alien-function return-type))
+ (cleanup-arguments (mapcar #'cleanup-function arg-types)))
+
#'(lambda (&rest args)
(map-into args #'funcall translate-arguments args)
(prog1
- (funcall
- translate-return-value (apply #'alien:alien-funcall alien args))
+ (funcall translate-return-value
+ (apply #'alien:alien-funcall alien args))
(mapc #'funcall cleanup-arguments args)))))
-
-(defun type-translateable-p (type-spec)
- (find-applicable-type-method type-spec 'translate-type-spec nil))
-
-(defun every-type-translateable-p (type-specs)
- (every #'type-translateable-p type-specs))
-
-(defun mkbinding-late (name return-type &rest arg-types)
- (if (every-type-translateable-p (cons return-type arg-types))
- (apply #'mkbinding name return-type arg-types)
- (let ((binding nil))
- #'(lambda (&rest args)
- (cond
- (binding (apply binding args))
- ((every-type-translateable-p (cons return-type arg-types))
- (setq binding (apply #'mkbinding name return-type arg-types))
- (apply binding args))
- (t
- (dolist (type-spec (cons return-type arg-types))
- (unless (type-translateable-p type-spec)
- (error "Can't translate type ~A" type-spec)))))))))
-
;;;; Definitons and translations of fundamental types
-(deftype long (&optional (min '*) (max '*)) `(integer ,min ,max))
-(deftype unsigned-long (&optional (min '*) (max '*)) `(integer ,min ,max))
-(deftype int (&optional (min '*) (max '*)) `(long ,min ,max))
-(deftype unsigned-int (&optional (min '*) (max '*)) `(unsigned-long ,min ,max))
-(deftype short (&optional (min '*) (max '*)) `(int ,min ,max))
-(deftype unsigned-short (&optional (min '*) (max '*)) `(unsigned-int ,min ,max))
-(deftype signed (&optional (size '*)) `(signed-byte ,size))
-(deftype unsigned (&optional (size '*)) `(signed-byte ,size))
-(deftype char () 'base-char)
-(deftype pointer () 'system-area-pointer)
-(deftype boolean (&optional (size '*))
- (declare (ignore size))
- `(member t nil))
-(deftype invalid () nil)
-
-(defun atomic-type-p (type-spec)
- (or
- (eq type-spec 'pointer)
- (not (eq (translate-type-spec type-spec) 'system-area-pointer))))
-
-
-(deftype-method cleanup-alien t (type-spec sap &optional weak-ref)
- (declare (ignore type-spec sap weak-ref))
- nil)
-
-
-(deftype-method translate-to-alien integer (type-spec number &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- number)
-
-(deftype-method translate-from-alien integer (type-spec number &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- number)
-
-
-(deftype-method translate-type-spec fixnum (type-spec)
- (declare (ignore type-spec))
- (translate-type-spec 'signed))
-
-(deftype-method size-of fixnum (type-spec)
- (declare (ignore type-spec))
- (size-of 'signed))
-
-(deftype-method translate-to-alien fixnum (type-spec number &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- number)
-
-(deftype-method translate-from-alien fixnum (type-spec number &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- number)
-
-
-(deftype-method translate-type-spec long (type-spec)
- (declare (ignore type-spec))
- `(signed ,(* +bits-per-unit+ +size-of-long+)))
-
-(deftype-method size-of long (type-spec)
- (declare (ignore type-spec))
- +size-of-long+)
-
-
-(deftype-method translate-type-spec unsigned-long (type-spec)
- (declare (ignore type-spec))
- `(unsigned ,(* +bits-per-unit+ +size-of-long+)))
-
-(deftype-method size-of unsigned-long (type-spec)
- (declare (ignore type-spec))
- +size-of-long+)
-
-
-(deftype-method translate-type-spec int (type-spec)
- (declare (ignore type-spec))
- `(signed ,(* +bits-per-unit+ +size-of-int+)))
-
-(deftype-method size-of int (type-spec)
- (declare (ignore type-spec))
- +size-of-int+)
-
-
-(deftype-method translate-type-spec unsigned-int (type-spec)
- (declare (ignore type-spec))
- `(unsigned ,(* +bits-per-unit+ +size-of-int+)))
-
-(deftype-method size-of unsigned-int (type-spec)
- (declare (ignore type-spec))
- +size-of-int+)
-
+(defmacro def-type-method (name args &optional documentation)
+ `(progn
+ (defgeneric ,name (,@args type &rest args)
+ ,@(when documentation `((:documentation ,documentation))))
+ (defmethod ,name (,@args (type symbol) &rest args)
+ (let ((class (find-class type nil)))
+ (if class
+ (apply #',name ,@args class args)
+ (multiple-value-bind (super-type expanded-p)
+ (type-expand-1 (cons type args))
+ (if expanded-p
+ (,name ,@args super-type)
+ (call-next-method))))))
+ (defmethod ,name (,@args (type cons) &rest args)
+ (declare (ignore args))
+ (apply #',name ,@args (first type) (rest type)))))
+
-(deftype-method translate-type-spec short (type-spec)
- (declare (ignore type-spec))
- `(signed ,(* +bits-per-unit+ +size-of-short+)))
+(def-type-method alien-type ())
+(def-type-method size-of ())
+(def-type-method to-alien-form (form))
+(def-type-method from-alien-form (form))
+(def-type-method cleanup-form (form)
+ "Creates a form to clean up after the alien call has finished.")
-(deftype-method size-of short (type-spec)
- (declare (ignore type-spec))
- +size-of-short+)
+(def-type-method to-alien-function ())
+(def-type-method from-alien-function ())
+(def-type-method cleanup-function ())
+(def-type-method writer-function ())
+(def-type-method reader-function ())
+(def-type-method destroy-function ())
-(deftype-method translate-type-spec unsigned-short (type-spec)
- (declare (ignore type-spec))
- `(unsigned ,(* +bits-per-unit+ +size-of-short+)))
-(deftype-method size-of unsigned-short (type-spec)
- (declare (ignore type-spec))
- +size-of-short+)
+(deftype int () '(signed-byte #.+bits-of-int+))
+(deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
+(deftype long () '(signed-byte #.+bits-of-long+))
+(deftype unsigned-long () '(unsigned-byte #.+bits-of-long+))
+(deftype short () '(signed-byte #.+bits-of-short+))
+(deftype unsigned-short () '(unsigned-byte #.+bits-of-short+))
+(deftype signed (&optional (size '*)) `(signed-byte ,size))
+(deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
+(deftype char () 'base-char)
+(deftype pointer () 'system-area-pointer)
+(deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil))
+;(deftype invalid () nil)
-(deftype-method translate-type-spec signed-byte (type-spec)
- (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
- `(signed
- ,(cond
- ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
- (t size)))))
+(defmethod to-alien-form (form (type t) &rest args)
+ (declare (ignore type args))
+ form)
-(deftype-method size-of signed-byte (type-spec)
- (let ((size (second (mklist (type-expand-to 'signed-byte type-spec)))))
- (cond
- ((member size '(nil *)) +size-of-int+)
- (t (/ size +bits-per-unit+)))))
+(defmethod to-alien-function ((type t) &rest args)
+ (declare (ignore type args))
+ #'identity)
-(deftype-method translate-to-alien signed-byte (type-spec number &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- number)
+(defmethod from-alien-form (form (type t) &rest args)
+ (declare (ignore type args))
+ form)
-(deftype-method translate-from-alien signed-byte
- (type-spec number &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- number)
+(defmethod from-alien-function ((type t) &rest args)
+ (declare (ignore type args))
+ #'identity)
+
+(defmethod cleanup-form (form (type t) &rest args)
+ (declare (ignore form type args))
+ nil)
+(defmethod cleanup-function ((type t) &rest args)
+ (declare (ignore type args))
+ #'identity)
+
+(defmethod destroy-function ((type t) &rest args)
+ (declare (ignore type args))
+ #'(lambda (location offset)
+ (declare (ignore location offset))))
+
+
+(defmethod alien-type ((type (eql 'signed-byte)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (&optional (size '*)) args
+ (ecase size
+ (#.+bits-of-byte+ '(signed-byte 8))
+ (#.+bits-of-short+ 'c-call:short)
+ ((* #.+bits-of-int+) 'c-call:int)
+ (#.+bits-of-long+ 'c-call:long))))
+
+(defmethod size-of ((type (eql 'signed-byte)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (&optional (size '*)) args
+ (ecase size
+ (#.+bits-of-byte+ 1)
+ (#.+bits-of-short+ +size-of-short+)
+ ((* #.+bits-of-int+) +size-of-int+)
+ (#.+bits-of-long+ +size-of-long+))))
+
+(defmethod writer-function ((type (eql 'signed-byte)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (&optional (size '*)) args
+ (let ((size (if (eq size '*) +bits-of-int+ size)))
+ (ecase size
+ (8 #'(lambda (value location &optional (offset 0))
+ (setf (signed-sap-ref-8 location offset) value)))
+ (16 #'(lambda (value location &optional (offset 0))
+ (setf (signed-sap-ref-16 location offset) value)))
+ (32 #'(lambda (value location &optional (offset 0))
+ (setf (signed-sap-ref-32 location offset) value)))
+ (64 #'(lambda (value location &optional (offset 0))
+ (setf (signed-sap-ref-64 location offset) value)))))))
+
+(defmethod reader-function ((type (eql 'signed-byte)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (&optional (size '*)) args
+ (let ((size (if (eq size '*) +bits-of-int+ size)))
+ (ecase size
+ (8 #'(lambda (sap &optional (offset 0))
+ (signed-sap-ref-8 sap offset)))
+ (16 #'(lambda (sap &optional (offset 0))
+ (signed-sap-ref-16 sap offset)))
+ (32 #'(lambda (sap &optional (offset 0))
+ (signed-sap-ref-32 sap offset)))
+ (64 #'(lambda (sap &optional (offset 0))
+ (signed-sap-ref-64 sap offset)))))))
+
+(defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
+ (destructuring-bind (&optional (size '*)) args
+ (ecase size
+ (#.+bits-of-byte+ '(unsigned-byte 8))
+ (#.+bits-of-short+ 'c-call:unsigned-short)
+ ((* #.+bits-of-int+) 'c-call:unsigned-int)
+ (#.+bits-of-long+ 'c-call:unsigned-long))))
+
+(defmethod size-of ((type (eql 'unsigned-byte)) &rest args)
+ (apply #'size-of 'signed args))
+
+(defmethod writer-function ((type (eql 'unsigned-byte)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (&optional (size '*)) args
+ (let ((size (if (eq size '*) +bits-of-int+ size)))
+ (ecase size
+ (8 #'(lambda (value location &optional (offset 0))
+ (setf (sap-ref-8 location offset) value)))
+ (16 #'(lambda (value location &optional (offset 0))
+ (setf (sap-ref-16 location offset) value)))
+ (32 #'(lambda (value location &optional (offset 0))
+ (setf (sap-ref-32 location offset) value)))
+ (64 #'(lambda (value location &optional (offset 0))
+ (setf (sap-ref-64 location offset) value)))))))
+
+(defmethod reader-function ((type (eql 'unsigned-byte)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (&optional (size '*)) args
+ (let ((size (if (eq size '*) +bits-of-int+ size)))
+ (ecase size
+ (8 #'(lambda (sap &optional (offset 0))
+ (sap-ref-8 sap offset)))
+ (16 #'(lambda (sap &optional (offset 0))
+ (sap-ref-16 sap offset)))
+ (32 #'(lambda (sap &optional (offset 0))
+ (sap-ref-32 sap offset)))
+ (64 #'(lambda (sap &optional (offset 0))
+ (sap-ref-64 sap offset)))))))
+
+
+(defmethod alien-type ((type (eql 'integer)) &rest args)
+ (declare (ignore type args))
+ (alien-type 'signed-byte))
-(deftype-method translate-type-spec unsigned-byte (type-spec)
- (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
- `(signed
- ,(cond
- ((member size '(nil *)) (* +bits-per-unit+ +size-of-int+))
- (t size)))))
+(defmethod size-of ((type (eql 'integer)) &rest args)
+ (declare (ignore type args))
+ (size-of 'signed-byte))
-(deftype-method size-of unsigned-byte (type-spec)
- (let ((size (second (mklist (type-expand-to 'unsigned-byte type-spec)))))
- (cond
- ((member size '(nil *)) +size-of-int+)
- (t (/ size +bits-per-unit+)))))
-(deftype-method translate-to-alien unsigned-byte (type-spec number &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- number)
+(defmethod alien-type ((type (eql 'fixnum)) &rest args)
+ (declare (ignore type args))
+ (alien-type 'signed-byte))
-(deftype-method translate-from-alien unsigned-byte
- (type-spec number &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- number)
+(defmethod size-of ((type (eql 'fixnum)) &rest args)
+ (declare (ignore type args))
+ (size-of 'signed-byte))
-(deftype-method translate-type-spec single-float (type-spec)
- (declare (ignore type-spec))
- 'single-float)
+(defmethod alien-type ((type (eql 'single-float)) &rest args)
+ (declare (ignore type args))
+ 'alien:single-float)
-(deftype-method size-of single-float (type-spec)
- (declare (ignore type-spec))
+(defmethod size-of ((type (eql 'single-float)) &rest args)
+ (declare (ignore type args))
+size-of-float+)
-(deftype-method translate-to-alien single-float (type-spec number &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- number)
+(defmethod writer-function ((type (eql 'single-float)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (value location &optional (offset 0))
+ (setf (sap-ref-single location offset) (coerce value 'single-float)))))
-(deftype-method translate-from-alien single-float
- (type-spec number &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- number)
+(defmethod reader-function ((type (eql 'single-float)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (sap &optional (offset 0))
+ (sap-ref-single sap offset)))
-(deftype-method translate-type-spec double-float (type-spec)
- (declare (ignore type-spec))
- 'double-float)
+(defmethod alien-type ((type (eql 'double-float)) &rest args)
+ (declare (ignore type args))
+ 'alien:double-float)
-(deftype-method size-of double-float (type-spec)
- (declare (ignore type-spec))
- +size-of-double+)
+(defmethod size-of ((type (eql 'double-float)) &rest args)
+ (declare (ignore type args))
+ +size-of-float+)
-(deftype-method translate-to-alien double-float (type-spec number &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- `(coerce ,number 'double-float))
+(defmethod writer-function ((type (eql 'double-float)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (value location &optional (offset 0))
+ (setf (sap-ref-double location offset) (coerce value 'double-float))))
-(deftype-method translate-from-alien double-float
- (type-spec number &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- number)
+(defmethod reader-function ((type (eql 'double-float)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (sap &optional (offset 0))
+ (sap-ref-double sap offset)))
-(deftype-method translate-type-spec base-char (type-spec)
- (declare (ignore type-spec))
- `(unsigned ,+bits-per-unit+))
+(defmethod alien-type ((type (eql 'base-char)) &rest args)
+ (declare (ignore type args))
+ 'c-call:char)
-(deftype-method size-of base-char (type-spec)
- (declare (ignore type-spec))
+(defmethod size-of ((type (eql 'base-char)) &rest args)
+ (declare (ignore type args))
1)
-(deftype-method translate-to-alien base-char (type-spec char &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- `(char-code ,char))
+(defmethod writer-function ((type (eql 'base-char)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (char location &optional (offset 0))
+ (setf (sap-ref-8 location offset) (char-code char))))
-(deftype-method translate-from-alien base-char (type-spec code &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- `(code-char ,code))
+(defmethod reader-function ((type (eql 'base-char)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (location &optional (offset 0))
+ (code-char (sap-ref-8 location offset))))
-(deftype-method translate-type-spec string (type-spec)
- (declare (ignore type-spec))
- 'system-area-pointer)
+(defmethod alien-type ((type (eql 'string)) &rest args)
+ (declare (ignore type args))
+ (alien-type 'pointer))
-(deftype-method size-of string (type-spec)
- (declare (ignore type-spec))
- +size-of-sap+)
+(defmethod size-of ((type (eql 'string)) &rest args)
+ (declare (ignore type args))
+ (size-of 'pointer))
-(deftype-method translate-to-alien string (type-spec string &optional weak-ref)
- (declare (ignore type-spec weak-ref))
+(defmethod to-alien-form (string (type (eql 'string)) &rest args)
+ (declare (ignore type args))
`(let ((string ,string))
;; Always copy strings to prevent seg fault due to GC
(copy-memory
(make-pointer (1+ (kernel:get-lisp-obj-address string)))
(1+ (length string)))))
-
-(deftype-method translate-from-alien string
- (type-spec c-string &optional weak-ref)
- (declare (ignore type-spec))
- `(let ((c-string ,c-string))
- (unless (null-pointer-p c-string)
- (prog1
- (c-call::%naturalize-c-string c-string)
- ;,(unless weak-ref `(deallocate-memory c-string))
- ))))
-
-(deftype-method cleanup-alien string (type-spec c-string &optional weak-ref)
- (when weak-ref
- (unreference-alien type-spec c-string)))
-
-(deftype-method unreference-alien string (type-spec c-string)
- (declare (ignore type-spec))
- `(let ((c-string ,c-string))
- (unless (null-pointer-p c-string)
- (deallocate-memory c-string))))
-
-
-;;; Pathname
-
-(deftype-method translate-type-spec pathname (type-spec)
- (declare (ignore type-spec))
- (translate-type-spec 'string))
-
-(deftype-method size-of pathname (type-spec)
- (declare (ignore type-spec))
- (size-of 'string))
-
-(deftype-method translate-to-alien pathname (type-spec path &optional weak-ref)
- (declare (ignore type-spec))
- (translate-to-alien 'string
- `(namestring (translate-logical-pathname ,path)) weak-ref))
-
-(deftype-method translate-from-alien pathname (type-spec c-string &optional weak-ref)
- (declare (ignore type-spec))
- `(parse-namestring ,(translate-from-alien 'string c-string weak-ref)))
-
-(deftype-method cleanup-alien pathname (type-spec c-string &optional weak-ref)
- (declare (ignore type-spec))
- (cleanup-alien 'string c-string weak-ref))
-
-(deftype-method unreference-alien pathname (type-spec c-string)
- (declare (ignore type-spec))
- (unreference-alien 'string c-string))
+(defmethod to-alien-function ((type (eql 'string)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (string)
+ (copy-memory
+ (make-pointer (1+ (kernel:get-lisp-obj-address string)))
+ (1+ (length string)))))
+
+(defmethod from-alien-form (string (type (eql 'string)) &rest args)
+ (declare (ignore type args))
+ `(let ((string ,string))
+ (unless (null-pointer-p string)
+ (c-call::%naturalize-c-string string))))
-(deftype-method translate-type-spec boolean (type-spec)
- (translate-type-spec
- (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
+(defmethod from-alien-function ((type (eql 'string)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (string)
+ (unless (null-pointer-p string)
+ (c-call::%naturalize-c-string string))))
-(deftype-method size-of boolean (type-spec)
- (size-of
- (cons 'unsigned (cdr (mklist (type-expand-to 'boolean type-spec))))))
+(defmethod cleanup-form (string (type (eql 'string)) &rest args)
+ (declare (ignore type args))
+ `(let ((string ,string))
+ (unless (null-pointer-p string)
+ (deallocate-memory string))))
+
+(defmethod cleanup-function ((type (eql 'string)) &rest args)
+ #'(lambda (string)
+ (unless (null-pointer-p string)
+ (deallocate-memory string))))
+
+(defmethod writer-function ((type (eql 'string)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (string location &optional (offset 0))
+ (assert (null-pointer-p (sap-ref-sap location offset)))
+ (setf (sap-ref-sap location offset)
+ (copy-memory
+ (make-pointer (1+ (kernel:get-lisp-obj-address string)))
+ (1+ (length string))))))
+
+(defmethod reader-function ((type (eql 'string)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (location &optional (offset 0))
+ (unless (null-pointer-p (sap-ref-sap location offset))
+ (c-call::%naturalize-c-string (sap-ref-sap location offset)))))
+
+(defmethod destroy-function ((type (eql 'string)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (location &optional (offset 0))
+ (unless (null-pointer-p (sap-ref-sap location offset))
+ (deallocate-memory (sap-ref-sap location offset))
+ (setf (sap-ref-sap location offset) (make-pointer 0)))))
+
+
+(defmethod alien-type ((type (eql 'pathname)) &rest args)
+ (declare (ignore type args))
+ (alien-type 'string))
+
+(defmethod size-of ((type (eql 'pathname)) &rest args)
+ (declare (ignore type args))
+ (size-of 'string))
-(deftype-method translate-to-alien boolean (type-spec boolean &optional weak-ref)
- (declare (ignore type-spec weak-ref))
+(defmethod to-alien-form (path (type (eql 'pathname)) &rest args)
+ (declare (ignore type args))
+ (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string))
+
+(defmethod to-alien-function ((type (eql 'pathname)) &rest args)
+ (declare (ignore type args))
+ (let ((string-function (to-alien-function 'string)))
+ #'(lambda (path)
+ (funcall string-function (namestring path)))))
+
+(defmethod from-alien-form (string (type (eql 'pathname)) &rest args)
+ (declare (ignore type args))
+ `(parse-namestring ,(from-alien-form string 'string)))
+
+(defmethod from-alien-function ((type (eql 'pathname)) &rest args)
+ (declare (ignore type args))
+ (let ((string-function (from-alien-function 'string)))
+ #'(lambda (string)
+ (parse-namestring (funcall string-function string)))))
+
+(defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args)
+ (declare (ignore type args))
+ (cleanup-form string 'string))
+
+(defmethod cleanup-function ((type (eql 'pathnanme)) &rest args)
+ (declare (ignore type args))
+ (cleanup-function 'string))
+
+(defmethod writer-function ((type (eql 'pathname)) &rest args)
+ (declare (ignore type args))
+ (let ((string-writer (writer-function 'string)))
+ #'(lambda (path location &optional (offset 0))
+ (funcall string-writer (namestring path) location offset))))
+
+(defmethod reader-function ((type (eql 'pathname)) &rest args)
+ (declare (ignore type args))
+ (let ((string-reader (reader-function 'string)))
+ #'(lambda (location &optional (offset 0))
+ (let ((string (funcall string-reader location offset)))
+ (when string
+ (parse-namestring string))))))
+
+(defmethod destroy-function ((type (eql 'pathname)) &rest args)
+ (declare (ignore type args))
+ (destroy-function 'string))
+
+
+(defmethod alien-type ((type (eql 'boolean)) &rest args)
+ (apply #'alien-type 'signed-byte args))
+
+(defmethod size-of ((type (eql 'boolean)) &rest args)
+ (apply #'size-of 'signed-byte args))
+
+(defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args)
+ (declare (ignore type args))
`(if ,boolean 1 0))
-(deftype-method translate-from-alien boolean (type-spec int &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- `(not (zerop ,int)))
-
-
-(deftype-method translate-type-spec or (union-type)
- (let* ((member-types (cdr (type-expand-to 'or union-type)))
- (alien-type (translate-type-spec (first member-types))))
- (dolist (type (cdr member-types))
- (unless (eq alien-type (translate-type-spec type))
- (error "No common alien type specifier for union type: ~A" union-type)))
+(defmethod to-alien-function ((type (eql 'boolean)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (boolean)
+ (if boolean 1 0)))
+
+(defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args)
+ (declare (ignore type args))
+ `(not (zerop ,boolean)))
+
+(defmethod from-alien-function ((type (eql 'boolean)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (boolean)
+ (not (zerop boolean))))
+
+(defmethod writer-function ((type (eql 'boolean)) &rest args)
+ (declare (ignore type))
+ (let ((writer (apply #'writer-function 'signed-byte args)))
+ #'(lambda (boolean location &optional (offset 0))
+ (funcall writer (if boolean 1 0) location offset))))
+
+(defmethod reader-function ((type (eql 'boolean)) &rest args)
+ (declare (ignore type))
+ (let ((reader (apply #'reader-function 'signed-byte args)))
+ #'(lambda (location &optional (offset 0))
+ (not (zerop (funcall reader location offset))))))
+
+
+(defmethod alien-type ((type (eql 'or)) &rest args)
+ (let ((alien-type (alien-type (first args))))
+ (unless (every #'(lambda (type)
+ (eq alien-type (alien-type type)))
+ (rest args))
+ (error "No common alien type specifier for union type: ~A"
+ (cons type args)))
alien-type))
-(deftype-method size-of or (union-type)
- (size-of (first (cdr (type-expand-to 'or union-type)))))
-
-(deftype-method translate-to-alien or (union-type-spec expr &optional weak-ref)
- (destructuring-bind (name &rest type-specs)
- (type-expand-to 'or union-type-spec)
- (declare (ignore name))
- `(let ((value ,expr))
- (etypecase value
- ,@(map
- 'list
- #'(lambda (type-spec)
- (list type-spec (translate-to-alien type-spec 'value weak-ref)))
- type-specs)))))
-
-
-(deftype-method translate-type-spec system-area-pointer (type-spec)
- (declare (ignore type-spec))
+(defmethod size-of ((type (eql 'or)) &rest args)
+ (declare (ignore type))
+ (size-of (first args)))
+
+(defmethod to-alien-form (form (type (eql 'or)) &rest args)
+ (declare (ignore type))
+ `(let ((value ,form))
+ (etypecase value
+ ,@(mapcar
+ #'(lambda (type)
+ `(,type ,(to-alien-form 'value type)))
+ args))))
+
+(defmethod to-alien-function ((type (eql 'or)) &rest types)
+ (declare (ignore type))
+ (let ((functions (mapcar #'to-alien-function types)))
+ #'(lambda (value)
+ (loop
+ for function in functions
+ for type in types
+ when (typep value type)
+ do (return (funcall function value))
+ finally (error "~S is not of type ~A" value `(or ,@types))))))
+
+(defmethod alien-type ((type (eql 'system-area-pointer)) &rest args)
+ (declare (ignore type args))
'system-area-pointer)
-(deftype-method size-of system-area-pointer (type-spec)
- (declare (ignore type-spec))
- +size-of-sap+)
+(defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
+ (declare (ignore type args))
+ +size-of-pointer+)
-(deftype-method translate-to-alien system-area-pointer (type-spec sap &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- sap)
+(defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (sap location &optional (offset 0))
+ (setf (sap-ref-sap location offset) sap)))
-(deftype-method translate-from-alien system-area-pointer
- (type-spec sap &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- sap)
+(defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (location &optional (offset 0))
+ (sap-ref-sap location offset)))
-(deftype-method translate-type-spec null (type-spec)
- (declare (ignore type-spec))
- 'system-area-pointer)
+(defmethod alien-type ((type (eql 'null)) &rest args)
+ (declare (ignore type args))
+ (alien-type 'pointer))
-(deftype-method translate-to-alien null (type-spec expr &optional weak-ref)
- (declare (ignore type-spec expr weak-ref))
+(defmethod size-of ((type (eql 'null)) &rest args)
+ (declare (ignore type args))
+ (size-of 'pointer))
+
+(defmethod to-alien-form (null (type (eql 'null)) &rest args)
+ (declare (ignore null type args))
`(make-pointer 0))
+(defmethod to-alien-function ((type (eql 'null)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (null)
+ (declare (ignore null))
+ (make-pointer 0)))
-(deftype-method translate-type-spec nil (type-spec)
- (declare (ignore type-spec))
- 'void)
-(deftype-method translate-from-alien nil (type-spec expr &optional weak-ref)
- (declare (ignore type-spec weak-ref))
- `(progn
- ,expr
- (values)))
+(defmethod alien-type ((type (eql 'nil)) &rest args)
+ (declare (ignore type args))
+ 'c-call:void)
+
+(defmethod from-alien-function ((type (eql 'nil)) &rest args)
+ (declare (ignore type args))
+ #'(lambda (value)
+ (declare (ignore value))
+ (values)))
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gboxed.lisp,v 1.10 2004/10/27 14:58:59 espen Exp $
+;; $Id: gboxed.lisp,v 1.11 2004/11/06 21:39:58 espen Exp $
(in-package "GLIB")
(eval-when (:compile-toplevel :load-toplevel :execute)
- (init-types-in-library "libgobject-2.0.so")
- (defclass boxed (proxy)
- ()
- (:metaclass proxy-class)
- (:copy %boxed-copy)
- (:free %boxed-free)))
+ (init-types-in-library #.(concatenate 'string
+ (pkg-config:pkg-variable "glib-2.0" "libdir")
+ "/libgobject-2.0.so")))
-(defbinding %boxed-copy (type location) pointer
- ((find-type-number type) type-number)
- (location pointer))
-
-(defbinding %boxed-free (type location) nil
- ((find-type-number type) type-number)
- (location pointer))
+(defclass boxed (proxy)
+ ()
+ (:metaclass struct-class))
;;;; Metaclass for boxed classes
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass boxed-class (proxy-class)
+ (defclass boxed-class (struct-class)
())
+ (defmethod validate-superclass ((class boxed-class) (super standard-class))
+ (subtypep (class-name super) 'boxed)))
- (defmethod shared-initialize ((class boxed-class) names
- &rest initargs &key name alien-name)
- (declare (ignore initargs names))
- (call-next-method)
-
- (let* ((class-name (or name (class-name class)))
- (type-number
- (find-type-number
- (or (first alien-name) (default-alien-type-name class-name)))))
- (register-type class-name type-number)))
+(defmethod shared-initialize ((class boxed-class) names
+ &rest initargs &key name alien-name)
+ (declare (ignore initargs names))
+ (call-next-method)
+
+ (let* ((class-name (or name (class-name class)))
+ (type-number
+ (find-type-number
+ (or (first alien-name) (default-alien-type-name class-name)))))
+ (register-type class-name type-number)))
- (defmethod validate-superclass
- ((class boxed-class) (super pcl::standard-class))
- (subtypep (class-name super) 'boxed)))
+
+(defbinding %boxed-copy (type location) pointer
+ ((find-type-number type) type-number)
+ (location pointer))
+
+(defbinding %boxed-free (type location) nil
+ ((find-type-number type) type-number)
+ (location pointer))
+
+(defmethod reference-foreign ((class boxed-class) location)
+ (%boxed-copy (class-name class) location))
+
+(defmethod unreference-foreign ((class boxed-class) location)
+ (%boxed-free (class-name class) location))
;;;;
;;;; Special boxed types
-(defclass gstring (boxed)
- ()
- (:metaclass boxed-class)
- (:alien-name "GString"))
-
-(deftype-method translate-from-alien
- gstring (type-spec location &optional weak-ref)
- `(let ((location ,location))
- (unless (null-pointer-p location)
- (prog1
- (c-call::%naturalize-c-string location)
- ,(unless weak-ref
- (unreference-alien type-spec location))))))
-
-(deftype-method translate-to-alien
- gstring (type-spec string &optional weak-ref)
- (declare (ignore weak-ref))
- `(let ((string ,string))
- ;; Always copy strings to prevent seg fault due to GC
- (funcall
- ',(proxy-class-copy (find-class type-spec))
- ',type-spec
- (make-pointer (1+ (kernel:get-lisp-obj-address string))))))
-
-(deftype-method cleanup-alien gstring (type-spec c-string &optional weak-ref)
- (when weak-ref
- (unreference-alien type-spec c-string)))
+;; (defclass gstring (boxed)
+;; ()
+;; (:metaclass boxed-class)
+;; (:alien-name "GString"))
+
+;; (deftype-method translate-from-alien
+;; gstring (type-spec location &optional weak-ref)
+;; `(let ((location ,location))
+;; (unless (null-pointer-p location)
+;; (prog1
+;; (c-call::%naturalize-c-string location)
+;; ,(unless weak-ref
+;; (unreference-alien type-spec location))))))
+
+;; (deftype-method translate-to-alien
+;; gstring (type-spec string &optional weak-ref)
+;; (declare (ignore weak-ref))
+;; `(let ((string ,string))
+;; ;; Always copy strings to prevent seg fault due to GC
+;; (funcall
+;; ',(proxy-class-copy (find-class type-spec))
+;; ',type-spec
+;; (make-pointer (1+ (kernel:get-lisp-obj-address string))))))
+
+;; (deftype-method cleanup-alien gstring (type-spec c-string &optional weak-ref)
+;; (when weak-ref
+;; (unreference-alien type-spec c-string)))
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gcallback.lisp,v 1.11 2004/11/01 00:08:49 espen Exp $
+;; $Id: gcallback.lisp,v 1.12 2004/11/06 21:39:58 espen Exp $
(in-package "GLIB")
(check-type function (or null symbol function))
(register-user-data function))
-(def-callback closure-callback-marshal
- (void (gclosure system-area-pointer) (return-value system-area-pointer)
- (n-params unsigned-int) (param-values system-area-pointer)
- (invocation-hint system-area-pointer) (callback-id unsigned-int))
+(def-callback closure-callback-marshal (c-call:void
+ (gclosure system-area-pointer)
+ (return-value system-area-pointer)
+ (n-params c-call:unsigned-int)
+ (param-values system-area-pointer)
+ (invocation-hint system-area-pointer)
+ (callback-id c-call:unsigned-int))
(callback-trampoline callback-id n-params param-values return-value))
-(def-callback %destroy-user-data (void (id unsigned-int))
+(def-callback %destroy-user-data (c-call:void (id c-call:unsigned-int))
(destroy-user-data id))
(defun make-callback-closure (function)
;;;; Timeouts and idle functions
-(def-callback source-callback-marshal (void (callback-id unsigned-int))
+(def-callback source-callback-marshal (c-call:void (callback-id c-call:unsigned-int))
(callback-trampoline callback-id 0 nil (make-pointer 0)))
(defbinding (timeout-add "g_timeout_add_full")
;; TODO: define and signal conditions based on log-level
;(defun log-handler (domain log-level message)
-(def-callback log-handler (void (domain c-string) (log-level int)
- (message c-string))
+(def-callback log-handler (c-call:void (domain c-call:c-string)
+ (log-level c-call:int)
+ (message c-call:c-string))
(error "~A: ~A" domain message))
(setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: genums.lisp,v 1.3 2001/10/21 22:02:01 espen Exp $
+;; $Id: genums.lisp,v 1.4 2004/11/06 21:39:58 espen Exp $
(in-package "GLIB")
-(defun %map-mappings (args op)
+(defun %map-enum (args op)
(let ((current-value 0))
- (map
- 'list
+ (mapcar
#'(lambda (mapping)
(destructuring-bind (symbol &optional (value current-value))
(mklist mapping)
(setf current-value (1+ value))
(case op
(:enum-int (list symbol value))
- (:flags-int (list symbol value #|(ash 1 value)|#))
+ (:flags-int (list symbol value))
(:int-enum (list value symbol))
- (:int-flags (list value #|(ash 1 value)|# symbol))
+ (:int-flags (list value symbol))
(:symbols symbol))))
- (if (integerp (first args))
- (rest args)
- args))))
+ args)))
(defun %query-enum-or-flags-values (query-function class type)
(multiple-value-bind (sap length)
(funcall query-function (type-class-ref type))
(let ((values nil)
- (size (proxy-class-size (find-class class)))
- (proxy (make-proxy-instance class sap nil)))
+ (size (proxy-instance-size (find-class class)))
+ (proxy (make-instance class :location sap)))
(dotimes (i length)
(with-slots (location nickname value) proxy
(setf location sap)
values)))
-;;;; Enum type
+;;;; Generic enum type
(deftype enum (&rest args)
- `(member ,@(%map-mappings args :symbols)))
-
-(deftype-method translate-type-spec enum (type-spec)
- (let ((args (cdr (type-expand-to 'enum type-spec))))
- (if (integerp (first args))
- (translate-type-spec `(signed ,(first args)))
- (translate-type-spec 'signed))))
-
-(deftype-method size-of enum (type-spec)
- (let ((args (cdr (type-expand-to 'enum type-spec))))
- (if (integerp (first args))
- (size-of `(signed ,(first args)))
- (size-of 'signed))))
-
-(deftype-method translate-to-alien enum (type-spec expr &optional weak-ref)
- (declare (ignore weak-ref))
- (let ((args (cdr (type-expand-to 'enum type-spec))))
- `(ecase ,expr
- ,@(%map-mappings args :enum-int))))
-
-(deftype-method translate-from-alien enum (type-spec expr &optional weak-ref)
- (declare (ignore weak-ref))
- (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec)
- (declare (ignore name))
- `(ecase ,expr
- ,@(%map-mappings args :int-enum))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass %enum-value (static)
- ((value :allocation :alien :type int)
- (name :allocation :alien :type string)
- (nickname :allocation :alien :type string))
- (:metaclass proxy-class)))
+ `(member ,@(%map-enum args :symbols)))
+
+(defmethod alien-type ((type (eql 'enum)) &rest args)
+ (declare (ignore type args))
+ (alien-type 'signed))
+
+(defmethod size-of ((type (eql 'enum)) &rest args)
+ (declare (ignore type args))
+ (size-of 'signed))
+
+(defmethod to-alien-form (form (type (eql 'enum)) &rest args)
+ (declare (ignore type))
+ `(ecase ,form
+ ,@(%map-enum args :enum-int)))
+
+(defmethod from-alien-form (form (type (eql 'enum)) &rest args)
+ (declare (ignore type))
+ `(ecase ,form
+ ,@(%map-enum args :int-enum)))
+
+(defmethod to-alien-function ((type (eql 'enum)) &rest args)
+ (let ((mappings (%map-enum args :enum-int)))
+ #'(lambda (enum)
+ (or
+ (second (assoc enum mappings))
+ (error "~S is not of type ~S" enum (cons type args))))))
+
+(defmethod from-alien-function ((type (eql 'enum)) &rest args)
+ (declare (ignore type))
+ (let ((mappings (%map-enum args :int-enum)))
+ #'(lambda (int)
+ (second (assoc int mappings)))))
+
+(defmethod writer-function ((type (eql 'enum)) &rest args)
+ (declare (ignore type))
+ (let ((writer (writer-function 'signed))
+ (function (apply #'to-alien-function 'enum args)))
+ #'(lambda (enum location &optional (offset 0))
+ (funcall writer (funcall function enum) location offset))))
+
+(defmethod reader-function ((type (eql 'enum)) &rest args)
+ (declare (ignore type))
+ (let ((reader (reader-function 'signed))
+ (function (apply #'from-alien-function 'enum args)))
+ #'(lambda (location &optional (offset 0))
+ (funcall function (funcall reader location offset)))))
+
+
+
+(defclass %enum-value (struct)
+ ((value :allocation :alien :type int)
+ (name :allocation :alien :type string)
+ (nickname :allocation :alien :type string))
+ (:metaclass static-struct-class))
(defbinding %enum-class-values () pointer
(class pointer)
-;;;; Flags type
+;;;; Generic flags type
(deftype flags (&rest args)
- `(or
- null
- (cons
- (member ,@(%map-mappings args :symbols))
- list)))
-
-(deftype-method translate-type-spec flags (type-spec)
- (let ((args (cdr (type-expand-to 'flags type-spec))))
- (if (integerp (first args))
- (translate-type-spec `(unsigned ,(first args)))
- (translate-type-spec 'unsigned))))
-
-(deftype-method size-of flags (type-spec)
- (let ((args (cdr (type-expand-to 'flags type-spec))))
- (if (integerp (first args))
- (size-of `(unsigned ,(first args)))
- (size-of 'unsigned))))
-
-(deftype-method translate-to-alien flags (type-spec expr &optional weak-ref)
- (declare (ignore weak-ref))
- (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
- (declare (ignore name))
- (let ((mappings (%map-mappings args :flags-int))
- (value (make-symbol "VALUE")))
- `(let ((,value 0))
- (dolist (flag ,expr ,value)
- (setq ,value (logior ,value (second (assoc flag ',mappings)))))))))
-
-(deftype-method translate-from-alien flags (type-spec expr &optional weak-ref)
- (declare (ignore weak-ref))
- (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec)
- (declare (ignore name))
- (let ((mappings (%map-mappings args :int-flags))
- (result (make-symbol "RESULT")))
- `(let ((,result nil))
- (dolist (mapping ',mappings ,result)
- (unless (zerop (logand ,expr (first mapping)))
- (push (second mapping) ,result)))))))
-
-
-
-;(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass %flags-value (static)
- ((value :allocation :alien :type unsigned-int)
- (name :allocation :alien :type string)
- (nickname :allocation :alien :type string))
- (:metaclass proxy-class));)
+ `(or null (cons (member ,@(%map-enum args :symbols)) list)))
+
+(defmethod alien-type ((type (eql 'flags)) &rest args)
+ (declare (ignore type args))
+ (alien-type 'unsigned))
+
+(defmethod size-of ((type (eql 'flags)) &rest args)
+ (declare (ignore type args))
+ (size-of 'unsigned))
+
+(defmethod to-alien-form (flags (type (eql 'flags)) &rest args)
+ `(loop
+ with value = 0
+ with flags = ,flags
+ for flag in (mklist flags)
+ do (let ((flagval
+ (or
+ (second (assoc flag ',(%map-enum args :flags-int)))
+ (error "~S is not of type ~S" flags '(,type ,@args)))))
+ (setq value (logior value flagval)))
+ finally (return value)))
+
+(defmethod from-alien-form (int (type (eql 'flags)) &rest args)
+ (declare (ignore type))
+ `(loop
+ for mapping in ',(%map-enum args :int-flags)
+ unless (zerop (logand int (first mapping)))
+ collect (second mapping)))
+
+(defmethod to-alien-function ((type (eql 'flags)) &rest args)
+ (let ((mappings (%map-enum args :flags-int)))
+ #'(lambda (flags)
+ (loop
+ with value = 0
+ for flag in (mklist flags)
+ do (let ((flagval (or
+ (second (assoc flag mappings))
+ (error "~S is not of type ~S" flags (cons type args)))))
+ (setq value (logior value flagval)))
+ finally (return value)))))
+
+(defmethod from-alien-function ((type (eql 'flags)) &rest args)
+ (declare (ignore type))
+ (let ((mappings (%map-enum args :int-flags)))
+ #'(lambda (int)
+ (loop
+ for mapping in mappings
+ unless (zerop (logand int (first mapping)))
+ collect (second mapping)))))
+
+(defmethod writer-function ((type (eql 'flags)) &rest args)
+ (declare (ignore type))
+ (let ((writer (writer-function 'unsigned))
+ (function (apply #'to-alien-function 'flags args)))
+ #'(lambda (flags location &optional (offset 0))
+ (funcall writer (funcall function flags) location offset))))
+
+(defmethod reader-function ((type (eql 'flags)) &rest args)
+ (declare (ignore type))
+ (let ((reader (reader-function 'unsigned))
+ (function (apply #'from-alien-function 'flags args)))
+ #'(lambda (location &optional (offset 0))
+ (funcall function (funcall reader location offset)))))
+
+
+
+(defclass %flags-value (struct)
+ ((value :allocation :alien :type unsigned-int)
+ (name :allocation :alien :type string)
+ (nickname :allocation :alien :type string))
+ (:metaclass static-struct-class))
(defbinding %flags-class-values () pointer
(class pointer)
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: ginterface.lisp,v 1.3 2004/10/31 00:56:29 espen Exp $
+;; $Id: ginterface.lisp,v 1.4 2004/11/06 21:39:58 espen Exp $
(in-package "GLIB")
(defclass ginterface ()
())
-(deftype-method translate-type-spec ginterface (type-spec)
- (declare (ignore type-spec))
- (translate-type-spec 'gobject))
-
-(deftype-method size-of ginterface (type-spec)
- (declare (ignore type-spec))
- (size-of 'gobject))
-
-(deftype-method translate-from-alien
- ginterface (type-spec location &optional weak-ref)
- (declare (ignore type-spec))
- (translate-from-alien 'gobject location weak-ref))
-
-(deftype-method translate-to-alien
- ginterface (type-spec instance &optional weak-ref)
- (declare (ignore type-spec))
- (translate-to-alien 'gobject instance weak-ref))
-
-
-
;;;; Metaclass for interfaces
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass ginterface-class (virtual-slot-class)
+ (defclass ginterface-class (virtual-slots-class)
()))
(defmethod direct-slot-definition-class ((class ginterface-class) &rest initargs)
(subtypep (class-name super) 'ginterface))
+(defmethod alien-type ((class ginterface-class) &rest args)
+ (declare (ignore class args))
+ (alien-type 'gobject))
+
+(defmethod size-of ((class ginterface-class) &rest args)
+ (declare (ignore class args))
+ (size-of 'gobject))
+
+(defmethod from-alien-form (location (class ginterface-class) &rest args)
+ (declare (ignore class args))
+ (from-alien-form location 'gobject))
+
+(defmethod from-alien-function ((class ginterface-class) &rest args)
+ (declare (ignore class args))
+ (from-alien-function 'gobject))
+
+(defmethod to-alien-form (instance (class ginterface-class) &rest args)
+ (declare (ignore class args))
+ (to-alien-form instance 'gobject))
+
+(defmethod to-alien-function ((class ginterface-class) &rest args)
+ (declare (ignore class args))
+ (to-alien-function 'gobject))
+
+
;;;;
(asdf:oos 'asdf:load-op :clg-tools)
(defpackage "GLIB-SYSTEM"
- (:use "COMMON-LISP" "ASDF" "PKG-CONFIG")
- (:export "*GTK-LIBRARY-PATH*"))
+ (:use "COMMON-LISP" "ASDF" "PKG-CONFIG"))
(ext:unlock-all-packages)
(defvar *cmucl-include-path* "/usr/lib/cmucl/include")
-;; TODO: remove this
-(defvar *gtk-library-path* (pkg-variable "gtk+-2.0" "libdir"))
-
(defsystem glib
:depends-on (clg-tools)
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: glib.lisp,v 1.15 2004/11/01 00:08:49 espen Exp $
+;; $Id: glib.lisp,v 1.16 2004/11/06 21:39:58 espen Exp $
(in-package "GLIB")
(defbinding (deallocate-memory "g_free") () nil
(address pointer))
-;(defun deallocate-memory (address)
-; (declare (ignore address)))
+;; (defun deallocate-memory (address)
+;; (declare (ignore address)))
(defun copy-memory (from length &optional (to (allocate-memory length)))
(kernel:system-area-copy from 0 to 0 (* 8 length))
;;;; Linked list (GList)
-(deftype glist (type) `(or (null (cons ,type list))))
+(deftype glist (type &key copy)
+ (declare (ignore copy))
+ `(or (null (cons ,type list))))
(defbinding (%glist-append-unsigned "g_list_append") () pointer
(glist pointer)
(glist pointer)
(data pointer))
-(defmacro glist-append (glist value type-spec)
- (ecase (first (mklist (translate-type-spec type-spec)))
- (unsigned `(%glist-append-unsigned ,glist ,value))
- (signed `(%glist-append-signed ,glist ,value))
- (system-area-pointer `(%glist-append-sap ,glist ,value))))
-
-(defmacro glist-data (glist type-spec)
- (ecase (first (mklist (translate-type-spec type-spec)))
- (unsigned `(sap-ref-unsigned ,glist 0))
- (signed `(sap-ref-signed ,glist 0))
- (system-area-pointer `(sap-ref-sap ,glist 0))))
+(defun make-glist (type list)
+ (let ((new-element (ecase (alien-type type)
+ (system-area-pointer #'%glist-append-sap)
+ ((signed-byte c-call:short c-call:int c-call:long)
+ #'%glist-append-signed)
+ ((unsigned-byte c-call:unsigned-short
+ c-call:unsigned-int c-call:unsigned-long)
+ #'%glist-append-unsigned)))
+ (to-alien (to-alien-function type)))
+ (loop
+ for element in list
+ as glist = (funcall new-element (or glist (make-pointer 0))
+ (funcall to-alien element))
+ finally (return glist))))
(defun glist-next (glist)
(unless (null-pointer-p glist)
- (sap-ref-sap glist +size-of-sap+)))
+ (sap-ref-sap glist +size-of-pointer+)))
+;; Also used for gslists
+(defun map-glist (seqtype function glist element-type)
+ (let ((reader (reader-function element-type)))
+ (case seqtype
+ ((nil)
+ (loop
+ as tmp = glist then (glist-next tmp)
+ until (null-pointer-p tmp)
+ do (funcall function (funcall reader tmp))))
+ (list
+ (loop
+ as tmp = glist then (glist-next tmp)
+ until (null-pointer-p tmp)
+ collect (funcall function (funcall reader tmp))))
+ (t
+ (coerce
+ (loop
+ as tmp = glist then (glist-next tmp)
+ until (null-pointer-p tmp)
+ collect (funcall function (funcall reader tmp)))
+ seqtype)))))
+
(defbinding (glist-free "g_list_free") () nil
(glist pointer))
-(deftype-method translate-type-spec glist (type-spec)
- (declare (ignore type-spec))
- (translate-type-spec 'pointer))
-(deftype-method size-of glist (type-spec)
- (declare (ignore type-spec))
+(defmethod alien-type ((type (eql 'glist)) &rest args)
+ (declare (ignore type args))
+ (alien-type 'pointer))
+
+(defmethod size-of ((type (eql 'glist)) &rest args)
+ (declare (ignore type args))
(size-of 'pointer))
-(deftype-method translate-to-alien glist (type-spec list &optional weak-ref)
- (declare (ignore weak-ref))
- (let* ((element-type (second (type-expand-to 'glist type-spec)))
- (element (translate-to-alien element-type 'element)))
- `(let ((glist (make-pointer 0)))
- (dolist (element ,list glist)
- (setq glist (glist-append glist ,element ,element-type))))))
-
-(deftype-method translate-from-alien
- glist (type-spec glist &optional weak-ref)
- (let ((element-type (second (type-expand-to 'glist type-spec))))
- `(let ((glist ,glist)
- (list nil))
- (do ((tmp glist (glist-next tmp)))
- ((null-pointer-p tmp))
- (push
- ,(translate-from-alien
- element-type `(glist-data tmp ,element-type) weak-ref)
- list))
- ,(unless weak-ref
- '(glist-free glist))
- (nreverse list))))
-
-(deftype-method cleanup-alien glist (type-spec glist &optional weak-ref)
- (when weak-ref
- (unreference-alien type-spec glist)))
-
-(deftype-method unreference-alien glist (type-spec glist)
- (let ((element-type (second (type-expand-to 'glist type-spec))))
+(defmethod to-alien-form (list (type (eql 'glist)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (element-type) args
+ `(make-glist ',element-type ,list)))
+
+(defmethod to-alien-function ((type (eql 'glist)) &rest args)
+ (declare (ignore type args))
+ (destructuring-bind (element-type) args
+ #'(lambda (list)
+ (make-glist element-type list))))
+
+(defmethod from-alien-form (glist (type (eql 'glist)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (element-type) args
`(let ((glist ,glist))
- (unless (null-pointer-p glist)
- ,(unless (atomic-type-p element-type)
- `(do ((tmp glist (glist-next tmp)))
- ((null-pointer-p tmp))
- ,(unreference-alien
- element-type `(glist-data tmp ,element-type))))
- (glist-free glist)))))
+ (unwind-protect
+ (map-glist 'list #'identity glist ',element-type)
+ (glist-free glist)))))
+
+(defmethod from-alien-function ((type (eql 'glist)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (element-type) args
+ #'(lambda (glist)
+ (unwind-protect
+ (map-glist 'list #'identity glist element-type)
+ (glist-free glist)))))
+
+(defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
+ (declare (ignore type args))
+ `(glist-free ,glist))
+
+(defmethod cleanup-function ((type (eql 'glist)) &rest args)
+ (declare (ignore type args))
+ #'glist-free)
+
;;;; Single linked list (GSList)
(gslist pointer)
(data pointer))
-(defmacro gslist-prepend (gslist value type-spec)
- (ecase (first (mklist (translate-type-spec type-spec)))
- (unsigned `(%gslist-prepend-unsigned ,gslist ,value))
- (signed `(%gslist-prepend-signed ,gslist ,value))
- (system-area-pointer `(%gslist-prepend-sap ,gslist ,value))))
-
+(defun make-gslist (type list)
+ (let ((new-element (ecase (alien-type type)
+ (system-area-pointer #'%gslist-prepend-sap)
+ ((signed-byte c-call:short c-call:int c-call:long)
+ #'%gslist-prepend-signed)
+ ((unsigned-byte c-call:unsigned-short
+ c-call:unsigned-int c-call:unsigned-long)
+ #'%gslist-prepend-unsigned)))
+ (to-alien (to-alien-function type)))
+ (loop
+ for element in (reverse list)
+ as gslist = (funcall new-element (or gslist (make-pointer 0))
+ (funcall to-alien element))
+ finally (return gslist))))
+
(defbinding (gslist-free "g_slist_free") () nil
(gslist pointer))
-(deftype-method translate-type-spec gslist (type-spec)
- (declare (ignore type-spec))
- (translate-type-spec 'pointer))
-(deftype-method size-of gslist (type-spec)
- (declare (ignore type-spec))
+(defmethod alien-type ((type (eql 'gslist)) &rest args)
+ (declare (ignore type args))
+ (alien-type 'pointer))
+
+(defmethod size-of ((type (eql 'gslist)) &rest args)
+ (declare (ignore type args))
(size-of 'pointer))
-(deftype-method translate-to-alien gslist (type-spec list &optional weak-ref)
- (declare (ignore weak-ref))
- (let* ((element-type (second (type-expand-to 'gslist type-spec)))
- (element (translate-to-alien element-type 'element)))
- `(let ((gslist (make-pointer 0)))
- (dolist (element (reverse ,list) gslist)
- (setq gslist (gslist-prepend gslist ,element ,element-type))))))
-
-(deftype-method translate-from-alien
- gslist (type-spec gslist &optional weak-ref)
- (let ((element-type (second (type-expand-to 'gslist type-spec))))
- `(let ((gslist ,gslist)
- (list nil))
- (do ((tmp gslist (glist-next tmp)))
- ((null-pointer-p tmp))
- (push
- ,(translate-from-alien
- element-type `(glist-data tmp ,element-type) weak-ref)
- list))
- ,(unless weak-ref
- '(gslist-free gslist))
- (nreverse list))))
-
-(deftype-method cleanup-alien gslist (type-spec gslist &optional weak-ref)
- (when weak-ref
- (unreference-alien type-spec gslist)))
-
-(deftype-method unreference-alien gslist (type-spec gslist)
- (let ((element-type (second (type-expand-to 'gslist type-spec))))
+(defmethod to-alien-form (list (type (eql 'gslist)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (element-type) args
+ `(make-sglist ',element-type ,list)))
+
+(defmethod to-alien-function ((type (eql 'gslist)) &rest args)
+ (declare (ignore type args))
+ (destructuring-bind (element-type) args
+ #'(lambda (list)
+ (make-gslist element-type list))))
+
+(defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (element-type) args
`(let ((gslist ,gslist))
- (unless (null-pointer-p gslist)
- ,(unless (atomic-type-p element-type)
- `(do ((tmp gslist (glist-next tmp)))
- ((null-pointer-p tmp))
- ,(unreference-alien
- element-type `(glist-data tmp ,element-type))))
- (gslist-free gslist)))))
+ (unwind-protect
+ (map-glist 'list #'identity gslist ',element-type)
+ (gslist-free gslist)))))
+(defmethod from-alien-function ((type (eql 'gslist)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (element-type) args
+ #'(lambda (gslist)
+ (unwind-protect
+ (map-glist 'list #'identity gslist element-type)
+ (gslist-free gslist)))))
+(defmethod cleanup-form (list (type (eql 'gslist)) &rest args)
+ (declare (ignore type args))
+ `(gslist-free ,list))
-;;; Vector
+(defmethod cleanup-function ((type (eql 'gslist)) &rest args)
+ (declare (ignore type args))
+ #'gslist-free)
-(defvar *magic-end-of-array* (allocate-memory 1))
-(deftype-method translate-type-spec vector (type-spec)
- (declare (ignore type-spec))
- (translate-type-spec 'pointer))
-(deftype-method size-of vector (type-spec)
- (declare (ignore type-spec))
- (size-of 'pointer))
+;;; Vector
-(deftype-method translate-to-alien vector (type-spec vector &optional weak-ref)
- (declare (ignore weak-ref))
- (destructuring-bind (element-type &optional (length '*))
- (cdr (type-expand-to 'vector type-spec))
- (let* ((element-size (size-of element-type))
- (size (cond
- ((not (eq length '*))
- (* element-size length))
- ((not (atomic-type-p element-type))
- `(* ,element-size (1+ (length vector))))
- (t
- `(* ,element-size (length vector))))))
-
- `(let ((vector ,vector))
- (let ((c-vector (allocate-memory ,size)))
- (dotimes (i ,(if (eq length '*) '(length vector) length))
- (setf
- (,(sap-ref-fname element-type) c-vector (* i ,element-size))
- ,(translate-to-alien element-type '(aref vector i))))
- ,(when (and
- (eq length '*)
- (not (atomic-type-p element-type)))
- `(setf
- (sap-ref-sap c-vector (* (length vector) ,element-size))
- *magic-end-of-array*))
- c-vector)))))
-
-(deftype-method translate-from-alien
- vector (type-spec c-array &optional weak-ref)
- (destructuring-bind (element-type &optional (length '*))
- (cdr (type-expand-to 'vector type-spec))
- (when (eq length '*)
- (error "Can't use vectors of variable length as return type"))
- (let ((element-size (size-of element-type)))
- `(let ((c-array ,c-array)
- (vector (make-array ,length :element-type ',element-type)))
- (dotimes (i ,length)
- (setf
- (aref vector i)
- ,(translate-from-alien
- element-type
- `(,(sap-ref-fname element-type) c-array (* i ,element-size))
- weak-ref)))
- ,(unless weak-ref
- '(deallocate-memory c-vector))
- vector))))
-
-
-(deftype-method cleanup-alien vector (type-spec c-vector &optional weak-ref)
- (when weak-ref
- (unreference-alien type-spec c-vector)))
-
-(deftype-method unreference-alien vector (type-spec c-vector)
- (destructuring-bind (element-type &optional (length '*))
- (cdr (type-expand-to 'vector type-spec))
- `(let ((c-vector ,c-vector))
- (unless (null-pointer-p c-vector)
- ,(unless (atomic-type-p element-type)
- (let ((element-size (size-of element-type)))
- (if (not (eq length '*))
- `(dotimes (i ,length)
- (unreference-alien
- element-type (sap-ref-sap c-vector (* i ,element-size))))
- `(do ((offset 0 (+ offset ,element-size)))
- ((sap=
- (sap-ref-sap c-vector offset)
- *magic-end-of-array*))
- ,(unreference-alien
- element-type '(sap-ref-sap c-vector offset))))))
- (deallocate-memory c-vector)))))
-
-
-(defun map-c-array (seqtype function location element-type length)
- (let ((reader (intern-reader-function element-type))
- (size (size-of element-type)))
+(defun make-c-vector (type length &optional content location)
+ (let* ((size-of-type (size-of type))
+ (location (or location (allocate-memory (* size-of-type length))))
+ (writer (writer-function type)))
+ (loop
+ for element across content
+ for i from 0 below length
+ as offset = 0 then (+ offset size-of-type)
+ do (funcall writer element location offset))
+ location))
+
+
+(defun map-c-vector (seqtype function location element-type length)
+ (let ((reader (reader-function element-type))
+ (size-of-element (size-of element-type)))
(case seqtype
((nil)
- (dotimes (i length)
- (funcall function (funcall reader location (* i size)))))
+ (loop
+ for i from 0 below length
+ as offset = 0 then (+ offset size-of-element)
+ do (funcall function (funcall reader location offset))))
(list
- (let ((list nil))
- (dotimes (i length)
- (push (funcall function (funcall reader location (* i size))) list))
- (nreverse list)))
+ (loop
+ for i from 0 below length
+ as offset = 0 then (+ offset size-of-element)
+ collect (funcall function (funcall reader location offset))))
(t
- (let ((sequence (make-sequence seqtype length)))
- (dotimes (i length)
- (setf
+ (loop
+ with sequence = (make-sequence seqtype length)
+ for i from 0 below length
+ as offset = 0 then (+ offset size-of-element)
+ do (setf
(elt sequence i)
- (funcall function (funcall reader location (* i size)))))
- sequence)))))
+ (funcall function (funcall reader location offset)))
+ finally (return sequence))))))
+
+
+(defmethod alien-type ((type (eql 'vector)) &rest args)
+ (declare (ignore type args))
+ (alien-type 'pointer))
+
+(defmethod size-of ((type (eql 'vector)) &rest args)
+ (declare (ignore type args))
+ (size-of 'pointer))
+
+(defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (element-type &optional (length '*)) args
+ (if (eq length '*)
+ `(let* ((vector ,vector)
+ (location (sap+
+ (allocate-memory (+ ,+size-of-int+
+ (* ,(size-of element-type)
+ (length vector))))
+ ,+size-of-int+)))
+ (make-c-vector ',element-type (length vector) vector location)
+ (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
+ location)
+ `(make-c-vector ',element-type ,length ,vector))))
+
+(defmethod from-alien-form (location (type (eql 'vector)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (element-type &optional (length '*)) args
+ (if (eq length '*)
+ (error "Can't use vector of variable size as return type")
+ `(map-c-vector 'vector #'identity ',element-type ',length ,location))))
+
+(defmethod cleanup-form (location (type (eql 'vector)) &rest args)
+ (declare (ignore type))
+ (destructuring-bind (element-type &optional (length '*)) args
+ `(let* ((location ,location)
+ (length ,(if (eq length '*)
+ `(sap-ref-32 location ,(- +size-of-int+))
+ length)))
+ (loop
+ with destroy = (destroy-function ',element-type)
+ for i from 0 below length
+ as offset = 0 then (+ offset ,(size-of element-type))
+ do (funcall destroy location offset))
+ (deallocate-memory ,(if (eq length '*)
+ `(sap+ location ,(- +size-of-int+))
+ 'location)))))
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gobject.lisp,v 1.16 2004/11/03 16:18:16 espen Exp $
+;; $Id: gobject.lisp,v 1.17 2004/11/06 21:39:58 espen Exp $
(in-package "GLIB")
(defclass gobject (ginstance)
()
(:metaclass ginstance-class)
- (:alien-name "GObject")
- (:copy %object-ref)
- (:free %object-unref)))
+ (:alien-name "GObject")))
+
+(defmethod print-object ((instance gobject) stream)
+ (print-unreadable-object (instance stream :type t :identity nil)
+ (if (slot-boundp instance 'location)
+ (format stream "at 0x~X" (sap-int (proxy-location instance)))
+ (write-string "(destroyed)" stream))))
(defmethod initialize-instance ((object gobject) &rest initargs)
- (let ((slotds (class-slots (class-of object)))
- (names (make-array 0 :adjustable t :fill-pointer t))
- (values (make-array 0 :adjustable t :fill-pointer t)))
-
- (loop
- as tmp = initargs then (cddr tmp) while tmp
- as key = (first tmp)
- as value = (second tmp)
- as slotd = (find-if
- #'(lambda (slotd)
- (member key (slot-definition-initargs slotd)))
- slotds)
- when (and (typep slotd 'effective-property-slot-definition)
- (slot-value slotd 'construct))
- do (let ((type (find-type-number (slot-definition-type slotd))))
- (vector-push-extend (slot-definition-pname slotd) names)
- (vector-push-extend (gvalue-new type value) values)
- (remf initargs key)))
-
- (setf
- (slot-value object 'location)
- (if (zerop (length names))
- (%gobject-new (type-number-of object))
- (%gobject-newvv (type-number-of object) (length names) names values)))
-
-; (map 'nil #'gvalue-free values)
- )
+ ;; Extract initargs which we should pass directly to the GObeject
+ ;; constructor
+ (let* ((slotds (class-slots (class-of object)))
+ (args (loop
+ as tmp = initargs then (cddr tmp) while tmp
+ as key = (first tmp)
+ as value = (second tmp)
+ as slotd = (find-if
+ #'(lambda (slotd)
+ (member key (slot-definition-initargs slotd)))
+ slotds)
+ when (and (typep slotd 'effective-property-slot-definition)
+ (slot-value slotd 'construct))
+ collect (progn
+ (remf initargs key)
+ (list
+ (slot-definition-pname slotd)
+ (slot-definition-type slotd)
+ value)))))
+ (if args
+ (let* ((string-size (size-of 'string))
+ (string-writer (writer-function 'string))
+ (string-destroy (destroy-function 'string))
+ (params (allocate-memory
+ (* (length args) (+ string-size +gvalue-size+)))))
+ (loop
+ for (pname type value) in args
+ as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
+ do (funcall string-writer pname tmp)
+ (gvalue-init (sap+ tmp string-size) type value))
+ (unwind-protect
+ (setf
+ (slot-value object 'location)
+ (%gobject-newv (type-number-of object) (length args) params))
+ (loop
+ repeat (length args)
+ as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
+ do (funcall string-destroy tmp)
+ (gvalue-unset (sap+ tmp string-size)))
+ (deallocate-memory params)))
+ (setf
+ (slot-value object 'location)
+ (%gobject-new (type-number-of object)))))
(%object-weak-ref object)
(apply #'call-next-method object initargs))
-(defmethod initialize-proxy ((object gobject) &rest initargs &key weak-ref)
+(defmethod initialize-instance :around ((object gobject) &rest initargs)
(declare (ignore initargs))
(call-next-method)
- (%object-weak-ref object)
- (unless weak-ref
- (object-ref object)))
+ (%object-weak-ref object))
-(def-callback weak-notify (void (data int) (location system-area-pointer))
- (when (instance-cached-p location)
- (warn "~A being finalized by the GObject system while still in existence in lisp" (find-cached-instance location))
- (remove-cached-instance location)))
+
+(def-callback weak-notify (c-call:void (data c-call:int) (location system-area-pointer))
+ (let ((object (find-cached-instance location)))
+ (when object
+;; (warn "~A being finalized by the GObject system while still in existence in lisp" object)
+ (slot-makunbound object 'location)
+ (remove-cached-instance location))))
(defbinding %object-weak-ref (object) nil
(object gobject)
((callback weak-notify) pointer)
(0 unsigned-int))
-
(defbinding (%gobject-new "g_object_new") () pointer
(type type-number)
(nil null))
-(defbinding (%gobject-newvv "g_object_newvv") () pointer
+(defbinding (%gobject-newv "g_object_newv") () pointer
(type type-number)
(n-parameters unsigned-int)
- (names (vector string))
- (values (vector gvalue)))
-
-
-(defbinding %object-ref (type location) pointer
- (location pointer))
-
- (defbinding %object-unref (type location) nil
- (location pointer))
-
-(defun object-ref (object)
- (%object-ref nil (proxy-location object)))
-
-(defun object-unref (object)
- (%object-unref nil (proxy-location object)))
+ (params pointer))
;;;; Metaclass used for subclasses of gobject
-(eval-when (:compile-toplevel :load-toplevel :execute)
+;(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass gobject-class (ginstance-class)
())
((pname :reader slot-definition-pname :initarg :pname)
(readable :reader slot-readable-p :initarg :readable)
(writable :reader slot-writable-p :initarg :writable)
- (construct :initarg :construct))))
+ (construct :initarg :construct)));)
+(defbinding %object-ref () pointer
+ (location pointer))
+
+(defbinding %object-unref () nil
+ (location pointer))
+
+(defmethod reference-foreign ((class gobject-class) location)
+ (declare (ignore class))
+ (%object-ref location))
+
+(defmethod unreference-foreign ((class gobject-class) location)
+ (declare (ignore class))
+ (%object-unref location))
; (defbinding object-class-install-param () nil
(setf
(slot-value slotd 'reader-function)
(if (slot-readable-p slotd)
- #'(lambda (object)
- (with-gc-disabled
- (let ((gvalue (gvalue-new type-number)))
- (%object-get-property object pname gvalue)
- (unwind-protect
- (funcall
- (intern-reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) ; temporary workaround for wrong topological sorting of types
- (gvalue-free gvalue t)))))
+ (let () ;(reader (reader-function (type-from-number type-number))))
+ #'(lambda (object)
+ (let ((gvalue (gvalue-new type-number)))
+ (%object-get-property object pname gvalue)
+ (unwind-protect
+ (funcall #|reader|# (reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+)
+ (gvalue-free gvalue t)))))
#'(lambda (value object)
(error "Slot is not readable: ~A" (slot-definition-name slotd))))))
(setf
(slot-value slotd 'writer-function)
(if (slot-writable-p slotd)
- #'(lambda (value object)
- (with-gc-disabled
- (let ((gvalue (gvalue-new type-number)))
- (funcall
- (intern-writer-function (type-from-number type-number)) ; temporary
- value gvalue +gvalue-value-offset+)
- (%object-set-property object pname gvalue)
- (funcall
- (intern-destroy-function (type-from-number type-number)) ; temporary
- gvalue +gvalue-value-offset+)
- (gvalue-free gvalue nil)
- value)))
+ (let ();; (writer (writer-function (type-from-number type-number)))
+;; (destroy (destroy-function (type-from-number type-number))))
+ #'(lambda (value object)
+ (let ((gvalue (gvalue-new type-number)))
+ (funcall #|writer|# (writer-function (type-from-number type-number)) value gvalue +gvalue-value-offset+)
+ (%object-set-property object pname gvalue)
+; (funcall #|destroy|#(destroy-function (type-from-number type-number)) gvalue +gvalue-value-offset+)
+ (gvalue-free gvalue t)
+ value)))
#'(lambda (value object)
(error "Slot is not writable: ~A" (slot-definition-name slotd))))))
(defun %map-params (params length type inherited-p)
(if inherited-p
- (map-c-array 'list #'identity params 'param length)
+ (map-c-vector 'list #'identity params 'param length)
(let ((properties ()))
- (map-c-array 'list
+ (map-c-vector 'list
#'(lambda (param)
(when (eql (param-owner-type param) type)
(push param properties)))
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gparam.lisp,v 1.8 2004/10/28 09:33:56 espen Exp $
+;; $Id: gparam.lisp,v 1.9 2004/11/06 21:39:58 espen Exp $
(in-package "GLIB")
(eval-when (:compile-toplevel :load-toplevel :execute)
(defbinding (size-of-gvalue "size_of_gvalue") () unsigned-int))
-(defconstant +gvalue-size+ (+ (size-of 'type-number) (* 2 (size-of 'double-float))))
+;(defconstant +gvalue-size+ (+ (size-of 'type-number) (* 2 (size-of 'double-float))))
(defconstant +gvalue-size+ #.(size-of-gvalue))
(defconstant +gvalue-value-offset+ (size-of 'type-number))
-(defbinding (gvalue-init "g_value_init") () nil
+(defbinding (%gvalue-init "g_value_init") () nil
(value gvalue)
(type type-number))
(defbinding (gvalue-unset "g_value_unset") () nil
(value gvalue))
+(defun gvalue-init (gvalue type &optional (value nil value-p))
+ (%gvalue-init gvalue (find-type-number type))
+ (when value-p
+ (funcall (writer-function type) value gvalue +gvalue-value-offset+)))
(defun gvalue-new (type &optional (value nil value-p))
(let ((gvalue (allocate-memory +gvalue-size+)))
- (gvalue-init gvalue (find-type-number type))
- (when value-p
- (gvalue-set gvalue value))
+ (if value-p
+ (gvalue-init gvalue type value)
+ (gvalue-init gvalue type))
gvalue))
-(defun gvalue-free (gvalue &optional unset-p)
+(defun gvalue-free (gvalue &optional (unset-p t))
(unless (null-pointer-p gvalue)
(when unset-p
(gvalue-unset gvalue))
(type-from-number (system:sap-ref-32 gvalue 0)))
(defun gvalue-get (gvalue)
- (funcall
- (intern-reader-function (gvalue-type gvalue))
+ (funcall (reader-function (gvalue-type gvalue))
gvalue +gvalue-value-offset+))
(defun gvalue-set (gvalue value)
- (funcall
- (intern-writer-function (gvalue-type gvalue))
+ (funcall (writer-function (gvalue-type gvalue))
value gvalue +gvalue-value-offset+)
value)
-(deftype-method unreference-alien gvalue (type-spec location)
- `(gvalue-free ,location nil))
-
-
(deftype param-flag-type ()
'(flags
(:lax-validation 16)
(:private 32)))
-;(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defclass param-spec-class (ginstance-class)
+ ())
+
+ (defmethod validate-superclass
+ ((class param-spec-class) (super pcl::standard-class))
+ t ;(subtypep (class-name super) 'param)
+))
+
+
+(defbinding %param-spec-ref () pointer
+ (location pointer))
+
+(defbinding %param-spec-unref () nil
+ (location pointer))
+
+(defmethod reference-foreign ((class param-spec-class) location)
+ (declare (ignore class))
+ (%param-spec-ref location))
+
+(defmethod unreference-foreign ((class param-spec-class) location)
+ (declare (ignore class))
+ (%param-spec-unref location))
+
+
+
;; TODO: rename to param-spec
- (defclass param (ginstance)
- ((name
- :allocation :alien
- :reader param-name
- :type string)
- (flags
- :allocation :alien
- :reader param-flags
- :type param-flag-type)
- (value-type
- :allocation :alien
- :reader param-value-type
- :type type-number)
- (owner-type
- :allocation :alien
- :reader param-owner-type
- :type type-number)
- (nickname
- :allocation :virtual
- :getter "g_param_spec_get_nick"
- :reader param-nickname
- :type string)
- (documentation
- :allocation :virtual
- :getter "g_param_spec_get_blurb"
- :reader param-documentation
- :type string))
- (:metaclass ginstance-class)
- (:ref "g_param_spec_ref")
- (:unref "g_param_spec_unref"));)
+(defclass param (ginstance)
+ ((name
+ :allocation :alien
+ :reader param-name
+ :type string)
+ (flags
+ :allocation :alien
+ :reader param-flags
+ :type param-flag-type)
+ (value-type
+ :allocation :alien
+ :reader param-value-type
+ :type type-number)
+ (owner-type
+ :allocation :alien
+ :reader param-owner-type
+ :type type-number)
+ (nickname
+ :allocation :virtual
+ :getter "g_param_spec_get_nick"
+ :reader param-nickname
+ :type string)
+ (documentation
+ :allocation :virtual
+ :getter "g_param_spec_get_blurb"
+ :reader param-documentation
+ :type string))
+ (:metaclass param-spec-class))
(defclass param-char (param)
:allocation :alien
:reader param-char-default-value
:type char))
- (:metaclass ginstance-class))
+ (:metaclass param-spec-class))
(defclass param-unsigned-char (param)
(
; :reader param-unsigned-char-default-value
; :type unsigned-char)
)
- (:metaclass ginstance-class)
+ (:metaclass param-spec-class)
(:alien-name "GParamUChar"))
(defclass param-boolean (param)
:allocation :alien
:reader param-boolean-default-value
:type boolean))
- (:metaclass ginstance-class))
+ (:metaclass param-spec-class))
(defclass param-int (param)
((minimum
:allocation :alien
:reader param-int-default-value
:type int))
- (:metaclass ginstance-class))
+ (:metaclass param-spec-class))
(defclass param-unsigned-int (param)
((minimum
:allocation :alien
:reader param-unsigned-int-default-value
:type unsigned-int))
- (:metaclass ginstance-class)
+ (:metaclass param-spec-class)
(:alien-name "GParamUInt"))
(defclass param-long (param)
:allocation :alien
:reader param-long-default-value
:type long))
- (:metaclass ginstance-class))
+ (:metaclass param-spec-class))
(defclass param-unsigned-long (param)
((minimum
:allocation :alien
:reader param-unsigned-long-default-value
:type unsigned-long))
- (:metaclass ginstance-class)
+ (:metaclass param-spec-class)
(:alien-name "GParamULong"))
(defclass param-unichar (param)
()
- (:metaclass ginstance-class))
+ (:metaclass param-spec-class))
(defclass param-enum (param)
((class
:allocation :alien
:reader param-enum-default-value
:type long))
- (:metaclass ginstance-class))
+ (:metaclass param-spec-class))
(defclass param-flags (param)
((class
:allocation :alien
:reader param-flags-default-value
:type long))
- (:metaclass ginstance-class))
+ (:metaclass param-spec-class))
(defclass param-single-float (param)
((minimum
:allocation :alien
:reader param-single-float-epsilon
:type single-float))
- (:metaclass ginstance-class)
+ (:metaclass param-spec-class)
(:alien-name "GParamFloat"))
(defclass param-double-float (param)
:allocation :alien
:reader param-double-float-epsilon
:type double-float))
- (:metaclass ginstance-class)
+ (:metaclass param-spec-class)
(:alien-name "GParamDouble"))
(defclass param-string (param)
:allocation :alien
:reader param-string-default-value
:type string))
- (:metaclass ginstance-class))
+ (:metaclass param-spec-class))
(defclass param-param (param)
()
- (:metaclass ginstance-class))
+ (:metaclass param-spec-class))
(defclass param-boxed (param)
()
- (:metaclass ginstance-class))
+ (:metaclass param-spec-class))
(defclass param-pointer (param)
()
- (:metaclass ginstance-class))
+ (:metaclass param-spec-class))
(defclass param-value-array (param)
((element-spec
:allocation :alien
:reader param-value-array-length
:type unsigned-int))
- (:metaclass ginstance-class))
+ (:metaclass param-spec-class))
;; (defclass param-closure (param)
;; ()
-;; (:metaclass ginstance-class))
+;; (:metaclass param-spec-class))
(defclass param-object (param)
()
- (:metaclass ginstance-class))
+ (:metaclass param-spec-class))
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: proxy.lisp,v 1.10 2004/11/03 16:18:16 espen Exp $
+;; $Id: proxy.lisp,v 1.11 2004/11/06 21:39:58 espen Exp $
(in-package "GLIB")
-(import
-'(pcl::initialize-internal-slot-functions
- pcl::compute-effective-slot-definition-initargs
- pcl::compute-slot-accessor-info
- pcl::reader-function pcl::writer-function pcl::boundp-function))
-
;;;; Superclass for all metaclasses implementing some sort of virtual slots
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass virtual-slot-class (standard-class)
+ (defclass virtual-slots-class (standard-class)
())
(defclass direct-virtual-slot-definition (standard-direct-slot-definition)
instances)))
(if object
(slot-value object slot)
- default)))
-)
+ default))))
-(defmethod direct-slot-definition-class ((class virtual-slot-class) &rest initargs)
+(defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs)
(if (eq (getf initargs :allocation) :virtual)
(find-class 'direct-virtual-slot-definition)
(call-next-method)))
-(defmethod effective-slot-definition-class ((class virtual-slot-class) &rest initargs)
+(defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs)
(if (eq (getf initargs :allocation) :virtual)
(find-class 'effective-virtual-slot-definition)
(call-next-method)))
(error "Can't read slot: ~A" (slot-definition-name slotd))))
(symbol #'(lambda (object)
(funcall getter object)))
- (string (let ((reader (mkbinding-late getter
- (slot-definition-type slotd) 'pointer)))
+ (string ;(let ()(reader (mkbinding getter
+;; (slot-definition-type slotd) 'pointer)))
(setf (slot-value slotd 'reader-function)
#'(lambda (object)
+ (let ((reader
+ (mkbinding getter
+ (slot-definition-type slotd) 'pointer)))
(funcall reader (proxy-location object)))))))))
(unless (slot-boundp slotd 'writer-function)
((or symbol cons) #'(lambda (value object)
(funcall (fdefinition setter) value object)))
(string
- (let ((writer (mkbinding-late setter 'nil 'pointer
- (slot-definition-type slotd))))
+ (let ((writer ()));; (mkbinding setter 'nil 'pointer
+;; (slot-definition-type slotd))))
(setf (slot-value slotd 'writer-function)
#'(lambda (value object)
+ (unless writer
+ (setq writer
+ (mkbinding setter 'nil 'pointer
+ (slot-definition-type slotd))))
(funcall writer (proxy-location object) value))))))))
(unless (slot-boundp slotd 'boundp-function)
type gf)
nil)
-(defmethod compute-effective-slot-definition-initargs ((class virtual-slot-class) direct-slotds)
+(defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
(if (eq (most-specific-slot-value direct-slotds 'allocation) :virtual)
(nconc
(list :getter (most-specific-slot-value direct-slotds 'getter)
(defmethod slot-value-using-class
- ((class virtual-slot-class) (object standard-object)
+ ((class virtual-slots-class) (object standard-object)
(slotd effective-virtual-slot-definition))
(if (funcall (slot-value slotd 'boundp-function) object)
(funcall (slot-value slotd 'reader-function) object)
(slot-unbound class object (slot-definition-name slotd))))
(defmethod slot-boundp-using-class
- ((class virtual-slot-class) (object standard-object)
+ ((class virtual-slots-class) (object standard-object)
(slotd effective-virtual-slot-definition))
(funcall (slot-value slotd 'boundp-function) object))
(defmethod (setf slot-value-using-class)
- (value (class virtual-slot-class) (object standard-object)
+ (value (class virtual-slots-class) (object standard-object)
(slotd effective-virtual-slot-definition))
(funcall (slot-value slotd 'writer-function) value object))
(defmethod validate-superclass
- ((class virtual-slot-class) (super standard-class))
+ ((class virtual-slots-class) (super standard-class))
t)
(defun remove-cached-instance (location)
(remhash (system:sap-int location) *instance-cache*))
+;; For debuging
+(defun cached-instances ()
+ (let ((instances ()))
+ (maphash #'(lambda (location ref)
+ (declare (ignore location))
+ (push (ext:weak-pointer-value ref) instances))
+ *instance-cache*)
+ instances))
+
;;;; Proxy for alien instances
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass proxy ()
- ((location :reader proxy-location :type system-area-pointer)))
+(defclass proxy ()
+ ((location :reader proxy-location :type system-area-pointer)))
- (defgeneric initialize-proxy (object &rest initargs))
- (defgeneric instance-finalizer (object)))
+(defgeneric initialize-proxy (object &rest initargs))
+(defgeneric instance-finalizer (object))
+(defgeneric reference-foreign (class location))
+(defgeneric unreference-foreign (class location))
+
+(defmethod unreference-foreign :around ((class class) location)
+ (unless (null-pointer-p location)
+;; (format t "Unreferencing ~A at ~A" (class-name class) location)
+;; (finish-output *standard-output*)
+ (call-next-method)
+;; (write-line " done")
+;; (finish-output *standard-output*)
+ ))
(defmethod print-object ((instance proxy) stream)
(print-unreadable-object (instance stream :type t :identity nil)
(format stream "at 0x~X" (sap-int (proxy-location instance)))))
+(defmethod print-object ((instance proxy) stream)
+ (print-unreadable-object (instance stream :type t :identity nil)
+ (format stream "at 0x~X" (sap-int (proxy-location instance)))))
-(defmethod initialize-instance :after ((instance proxy)
- &rest initargs &key)
- (declare (ignore initargs))
- (cache-instance instance)
- (ext:finalize instance (instance-finalizer instance)))
-(defmethod initialize-proxy ((instance proxy)
- &rest initargs &key location weak-ref)
- (declare (ignore initargs))
- (setf
- (slot-value instance 'location)
- (if weak-ref
- (funcall
- (proxy-class-copy (class-of instance))
- (type-of instance) location)
- location))
+(defmethod initialize-instance :around ((instance proxy) &key location)
+ (if location
+ (setf (slot-value instance 'location) location)
+ (call-next-method))
(cache-instance instance)
- (ext:finalize instance (instance-finalizer instance)))
+ (ext:finalize instance (instance-finalizer instance))
+ instance)
(defmethod instance-finalizer ((instance proxy))
- (let ((class (class-of instance))
- (type (type-of instance))
- (location (proxy-location instance)))
- (declare (type symbol type) (type system-area-pointer location))
- (let ((free (proxy-class-free class)))
- #'(lambda ()
- (when (instance-cached-p location)
- (remove-cached-instance location)
- (funcall free type location))))))
-
-
-(deftype-method translate-type-spec proxy (type-spec)
- (declare (ignore type-spec))
- (translate-type-spec 'pointer))
-
-(deftype-method size-of proxy (type-spec)
- (declare (ignore type-spec))
- (size-of 'pointer))
-
-(deftype-method translate-from-alien
- proxy (type-spec location &optional weak-ref)
- `(let ((location ,location))
- (unless (null-pointer-p location)
- (ensure-proxy-instance ',type-spec location ,weak-ref))))
-
-(deftype-method translate-to-alien
- proxy (type-spec instance &optional weak-ref)
- (if weak-ref
- `(proxy-location ,instance)
- (let ((copy (proxy-class-copy (find-class type-spec))))
- (if (symbolp copy)
- `(,copy ',type-spec (proxy-location ,instance))
- `(funcall ',copy ',type-spec (proxy-location ,instance))))))
-
-(deftype-method unreference-alien proxy (type-spec location)
- (let ((free (proxy-class-free (find-class type-spec))))
- (if (symbolp free)
- `(,free ',type-spec ,location)
- `(funcall ',free ',type-spec ,location))))
+ (let ((location (proxy-location instance))
+ (class (class-of instance)))
+;; (unless (find-method #'unreference-foreign nil (list (class-of class) t) nil)
+;; (error "No matching method for UNREFERENCE-INSTANCE when called with class ~A" class))
+ #'(lambda ()
+ (when (instance-cached-p location)
+ (remove-cached-instance location))
+ (unreference-foreign class location))))
;;;; Metaclass used for subclasses of proxy
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass proxy-class (virtual-slot-class)
- ((size :reader proxy-class-size)
- (copy :reader proxy-class-copy)
- (free :reader proxy-class-free)))
+ (defclass proxy-class (virtual-slots-class)
+ ((size :reader proxy-instance-size)))
(defclass direct-alien-slot-definition (direct-virtual-slot-definition)
((allocation :initform :alien)
(class-direct-superclasses class)))
(defmethod shared-initialize ((class proxy-class) names
- &rest initargs &key size copy free)
+ &rest initargs &key size)
(declare (ignore initargs))
(call-next-method)
(cond
(size (setf (slot-value class 'size) (first size)))
- ((slot-boundp class 'size) (slot-makunbound class 'size)))
- (cond
- (copy (setf (slot-value class 'copy) (first copy)))
- ((slot-boundp class 'copy) (slot-makunbound class 'copy)))
- (cond
- (free (setf (slot-value class 'free) (first free)))
- ((slot-boundp class 'free) (slot-makunbound class 'free))))
-
- (defmethod shared-initialize :after ((class proxy-class) names &rest initargs)
- (let ((super (most-specific-proxy-superclass class)))
- (unless (or (not super) (eq super (find-class 'proxy)))
- (unless (or (slot-boundp class 'copy) (not (slot-boundp super 'copy)))
- (setf (slot-value class 'copy) (proxy-class-copy super)))
- (unless (or (slot-boundp class 'free) (not (slot-boundp super 'free)))
- (setf (slot-value class 'free) (proxy-class-free super))))))
+ ((slot-boundp class 'size) (slot-makunbound class 'size))))
(defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
(case (getf initargs :allocation)
(defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition))
(with-slots (offset) slotd
- (let* ((type (slot-definition-type slotd))
- (reader (intern-reader-function type))
- (writer (intern-writer-function type))
- (destroy (intern-destroy-function type)))
+ (let ((type (slot-definition-type slotd)))
(unless (slot-boundp slotd 'reader-function)
- (setf
- (slot-value slotd 'reader-function)
- #'(lambda (object)
- (funcall reader (proxy-location object) offset))))
+ (let ((reader (reader-function type)))
+ (setf
+ (slot-value slotd 'reader-function)
+ #'(lambda (object)
+ (funcall reader (proxy-location object) offset)))))
(unless (slot-boundp slotd 'writer-function)
- (setf
- (slot-value slotd 'writer-function)
- #'(lambda (value object)
- (let ((location (proxy-location object)))
- (funcall destroy location offset)
- (funcall writer value location offset)))))
+ (let ((writer (writer-function type))
+ (destroy (destroy-function type)))
+ (setf
+ (slot-value slotd 'writer-function)
+ #'(lambda (value object)
+ (let ((location (proxy-location object)))
+ (funcall destroy location offset) ; destroy old value
+ (funcall writer value location offset))))))
(unless (slot-boundp slotd 'boundp-function)
(setf
(defconstant +struct-alignmen+ 4)
(defmethod compute-slots ((class proxy-class))
- ;; This stuff should really go somewhere else
(loop
- with offset = (proxy-class-size (most-specific-proxy-superclass class))
+ with offset = (proxy-instance-size (most-specific-proxy-superclass class))
with size = offset
for slotd in (class-direct-slots class)
when (eq (slot-definition-allocation slotd) :alien)
(defmethod validate-superclass ((class proxy-class) (super standard-class))
(subtypep (class-name super) 'proxy))
- (defmethod proxy-class-size (class)
+ (defmethod proxy-instance-size (class)
(declare (ignore class))
0)
)
-(defgeneric make-proxy-instance (class location weak-ref
- &rest initargs &key));)
+(defmethod alien-type ((class proxy-class) &rest args)
+ (declare (ignore class args))
+ (alien-type 'pointer))
+
+(defmethod size-of ((class proxy-class) &rest args)
+ (declare (ignore class args))
+ (size-of 'pointer))
+
+(defmethod from-alien-form (location (class proxy-class) &rest args)
+ (declare (ignore args))
+ `(ensure-proxy-instance ',(class-name class) ,location))
+
+(defmethod from-alien-function ((class proxy-class) &rest args)
+ (declare (ignore args))
+ #'(lambda (location)
+ (ensure-proxy-instance class location)))
-(defmethod make-proxy-instance ((class symbol) location weak-ref
- &rest initargs &key)
- (apply #'make-proxy-instance (find-class class) location weak-ref initargs))
+(defmethod to-alien-form (instance (class proxy-class) &rest args)
+ (declare (ignore class args))
+ `(proxy-location ,instance))
-(defmethod make-proxy-instance ((class proxy-class) location weak-ref
- &rest initargs &key)
- (let ((instance (allocate-instance class)))
- (apply
- #'initialize-proxy
- instance :location location :weak-ref weak-ref initargs)
- instance))
+(defmethod to-alien-function ((class proxy-class) &rest args)
+ (declare (ignore class args))
+ #'proxy-location)
+
+(defmethod writer-function ((class proxy-class) &rest args)
+ (declare (ignore args))
+ #'(lambda (instance location &optional (offset 0))
+ (assert (null-pointer-p (sap-ref-sap location offset)))
+ (setf
+ (sap-ref-sap location offset)
+ (reference-foreign class (proxy-location instance)))))
-(defun ensure-proxy-instance (class location weak-ref &rest initargs)
- (or
- (find-cached-instance location)
- (apply #'make-proxy-instance class location weak-ref initargs)))
+(defmethod reader-function ((class proxy-class) &rest args)
+ (declare (ignore args))
+ #'(lambda (location &optional (offset 0))
+ (ensure-proxy-instance class (sap-ref-sap location offset))))
+(defmethod destroy-function ((class proxy-class) &rest args)
+ (declare (ignore args))
+ #'(lambda (location &optional (offset 0))
+ (unreference-foreign class (sap-ref-sap location offset))))
+
+
+(defgeneric ensure-proxy-instance (class location)
+ (:documentation "Returns a proxy object representing the foreign object at the give location."))
+
+(defmethod ensure-proxy-instance :around (class location)
+ (unless (null-pointer-p location)
+ (or
+ (find-cached-instance location)
+ (call-next-method))))
+
+(defmethod ensure-proxy-instance ((class symbol) location)
+ (ensure-proxy-instance (find-class class) location))
+
+(defmethod ensure-proxy-instance ((class proxy-class) location)
+ (make-instance class :location location))
;;;; Superclasses for wrapping of C structures
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass struct (proxy)
- ()
- (:metaclass proxy-class)
- (:copy %copy-struct)
- (:free %free-struct)))
+(defclass struct (proxy)
+ ()
+ (:metaclass proxy-class))
-(defmethod initialize-instance ((structure struct) &rest initargs)
+(defmethod initialize-instance ((struct struct) &rest initargs)
(declare (ignore initargs))
(setf
- (slot-value structure 'location)
- (allocate-memory (proxy-class-size (class-of structure))))
+ (slot-value struct 'location)
+ (allocate-memory (proxy-instance-size (class-of struct))))
(call-next-method))
-(defun %copy-struct (type location)
- (copy-memory location (proxy-class-size (find-class type))))
+;;;; Metaclasses used for subclasses of struct
+
+(defclass struct-class (proxy-class)
+ ())
-(defun %free-struct (type location)
- (declare (ignore type))
+(defmethod reference-foreign ((class struct-class) location)
+ (copy-memory location (proxy-instance-size class)))
+
+(defmethod unreference-foreign ((class struct-class) location)
(deallocate-memory location))
+(defmethod reader-function ((class struct-class) &rest args)
+ (declare (ignore args))
+ #'(lambda (location &optional (offset 0))
+ (let ((instance (sap-ref-sap location offset)))
+ (unless (null-pointer-p instance)
+ (ensure-proxy-instance class (reference-foreign class instance))))))
+
-;(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass static (struct)
- ()
- (:metaclass proxy-class)
- (:copy %copy-static)
- (:free %free-static));)
+(defclass static-struct-class (struct-class)
+ ())
-(defun %copy-static (type location)
- (declare (ignore type))
+(defmethod reference-foreign ((class static-struct-class) location)
+ (declare (ignore class))
location)
-(defun %free-static (type location)
- (declare (ignore type location))
+(defmethod unreference-foreign ((class static-struct-class) location)
+ (declare (ignore class location))
nil)
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gtk.lisp,v 1.14 2004/11/03 10:41:23 espen Exp $
+;; $Id: gtk.lisp,v 1.15 2004/11/06 21:39:58 espen Exp $
(in-package "GTK")
(defbinding get-default-language () string)
+;;;; Initalization
+
+(defbinding (gtk-init "gtk_parse_args") () nil
+ "Initializes the library without opening the display."
+ (nil null)
+ (nil null))
+
+(defun clg-init (&optional display)
+ "Initializes the system and starts the event handling"
+ (unless (gdk:display-get-default)
+ (gdk:gdk-init)
+ (gtk-init)
+ (prog1
+ (gdk:display-open display)
+ (system:add-fd-handler
+ (gdk:display-connection-number) :input #'main-iterate-all)
+ (setq lisp::*periodic-polling-function* #'main-iterate-all)
+ (setq lisp::*max-event-to-sec* 0)
+ (setq lisp::*max-event-to-usec* 1000))))
+
+
;;; Acccel group
(defmethod shared-initialize ((combo combo) names &rest initargs
&key popdown-strings)
+ (declare (ignore initargs))
(call-next-method)
(when popdown-strings
(combo-set-popdown-strings combo popdown-strings)))
;;;; Dialog
(defmethod shared-initialize ((dialog dialog) names &rest initargs &key button)
+ (declare (ignore button))
(call-next-method)
(dolist (button-definition (get-all initargs :button))
(apply #'dialog-add-button dialog (mklist button-definition))))
(edge gdk:window-edge)
(button int)
(root-x int) (root-y int)
- (timestamp (unsigned-int 32)))
+ (timestamp unsigned-int))
(defbinding window-begin-move-drag () nil
(window window)
(edge gdk:window-edge)
(button int)
(root-x int) (root-y int)
- (timestamp (unsigned-int 32)))
+ (timestamp unsigned-int))
(defbinding window-set-frame-dimensions () nil
(window window)
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gtkobject.lisp,v 1.18 2004/11/03 16:54:24 espen Exp $
+;; $Id: gtkobject.lisp,v 1.19 2004/11/06 21:39:58 espen Exp $
(in-package "GTK")
;;;; Superclass for the gtk class hierarchy
(eval-when (:compile-toplevel :load-toplevel :execute)
- (init-types-in-library "libgtk-x11-2.0.so"
+ (init-types-in-library
+ #.(concatenate 'string (pkg-config:pkg-variable "gtk+-2.0" "libdir")
+ "/libgtk-x11-2.0.so")
:ignore ("gtk_window_get_type_hint"))
(defclass %object (gobject)
(:alien-name "GtkObject")))
-(defmethod shared-initialize ((object %object) names &rest initargs &key signal)
- (declare (ignore names signal))
+(defmethod initialize-instance ((object %object) &rest initargs &key signal)
+ (declare (ignore signal))
(call-next-method)
- (object-ref object) ; inc ref count before sinking
- (%object-sink object)
+ (reference-foreign (class-of object) (proxy-location object))
(dolist (signal-definition (get-all initargs :signal))
(apply #'signal-connect object signal-definition)))
-(defmethod initialize-proxy ((object %object) &rest initargs)
+(defmethod initialize-instance :around ((object %object) &rest initargs)
(declare (ignore initargs))
(call-next-method)
(%object-sink object))
(main-iteration-do nil)
(main-iterate-all)))
-;;;; Initalization
-
-(defbinding (gtk-init "gtk_parse_args") () nil
- "Initializes the library without opening the display."
- (nil null)
- (nil null))
-
-(defun clg-init (&optional display)
- "Initializes the system and starts the event handling"
- (unless (gdk:display-get-default)
- (gdk:gdk-init)
- (gtk-init)
- (prog1
- (gdk:display-open display)
- (system:add-fd-handler
- (gdk:display-connection-number) :input #'main-iterate-all)
- (setq lisp::*periodic-polling-function* #'main-iterate-all)
- (setq lisp::*max-event-to-sec* 0)
- (setq lisp::*max-event-to-usec* 1000))))
-
-
;;;; Metaclass for child classes
(defvar *container-to-child-class-mappings* (make-hash-table))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass child-class (virtual-slot-class)
+ (defclass child-class (virtual-slots-class)
())
(defclass direct-child-slot-definition (direct-virtual-slot-definition)
(gethash (find-class (first container)) *container-to-child-class-mappings*)
class))
-;; (defmethod initialize-instance ((slotd direct-child-slot-definition)
-;; &rest initargs &key pname)
-;; (declare (ignore initargs))
-;; (call-next-method)
-;; (if pname
-;; (setf (slot-value slotd 'pname) pname)
-;; ; ???
-;; (error "Need pname for slot with allocation :property")))
-
(defmethod direct-slot-definition-class ((class child-class) &rest initargs)
(case (getf initargs :allocation)
(:property (find-class 'direct-child-slot-definition))
(slot-value slotd 'reader-function)
#'(lambda (object)
(with-slots (parent child) object
- (with-gc-disabled
- (let ((gvalue (gvalue-new type-number)))
- (%container-child-get-property parent child pname gvalue)
- (unwind-protect
- (funcall
- (intern-reader-function type)
- gvalue +gvalue-value-offset+)
- (gvalue-free gvalue t))))))))
+ (let ((gvalue (gvalue-new type-number)))
+ (%container-child-get-property parent child pname gvalue)
+ (unwind-protect
+ (funcall (reader-function type) gvalue +gvalue-value-offset+)
+ (gvalue-free gvalue t)))))))
(unless (slot-boundp slotd 'writer-function)
(setf
(slot-value slotd 'writer-function)
#'(lambda (value object)
(with-slots (parent child) object
- (with-gc-disabled
- (let ((gvalue (gvalue-new type-number)))
- (funcall
- (intern-writer-function type)
- value gvalue +gvalue-value-offset+)
- (%container-child-set-property parent child pname gvalue)
- (funcall
- (intern-destroy-function type)
- gvalue +gvalue-value-offset+)
- (gvalue-free gvalue nil)
- value))))))
+ (let ((gvalue (gvalue-new type-number)))
+ (funcall (writer-function type) value gvalue +gvalue-value-offset+)
+ (%container-child-set-property parent child pname gvalue)
+;; (funcall
+;; (destroy-function type)
+;; gvalue +gvalue-value-offset+)
+ (gvalue-free gvalue t)
+ value)))))
(unless (slot-boundp slotd 'boundp-function)
(setf
(multiple-value-bind (array length)
(%container-class-list-child-properties class)
(unwind-protect
- (map-c-array 'list #'identity array 'param length)
+ (map-c-vector 'list #'identity array 'param length)
(deallocate-memory array)))))
(defun default-container-child-name (container-class)
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gtktypes.lisp,v 1.16 2004/10/31 12:05:52 espen Exp $
+;; $Id: gtktypes.lisp,v 1.17 2004/11/06 21:39:58 espen Exp $
(in-package "GTK")
:accessor allocation-height
:initarg :height
:type int))
- (:metaclass proxy-class))
+ (:metaclass struct-class))
(defclass border (boxed)
((left
:accessor stock-item-translation-domain
:initarg :translation-domain
:type string))
- (:metaclass proxy-class))
+ (:metaclass static-struct-class))
(define-types-by-introspection "Gtk"
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gtkwidget.lisp,v 1.9 2004/10/31 12:05:52 espen Exp $
+;; $Id: gtkwidget.lisp,v 1.10 2004/11/06 21:39:58 espen Exp $
(in-package "GTK")
(defun widget-get-size-request (widget)
(multiple-value-bind (width height) (%widget-get-size-request widget)
- (values (unless (= width -1) width) (unless (= height -1) height))))
+ (values (unless (= width -1) width) (unless (= height -1) height))))
(defbinding widget-set-size-request (widget width height) nil
(widget widget)
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: pango.lisp,v 1.5 2004/10/31 11:45:39 espen Exp $
+;; $Id: pango.lisp,v 1.6 2004/11/06 21:39:58 espen Exp $
(in-package "PANGO")
(eval-when (:compile-toplevel :load-toplevel :execute)
- (init-types-in-library "libpango-1.0.so" :ignore ("_pango_fribidi_get_type")))
+ (init-types-in-library
+ #.(concatenate 'string (pkg-config:pkg-variable "atk" "libdir")
+ "/libpango-1.0.so")
+ :prefix "pango_" :ignore ("_pango_fribidi_get_type")))
(define-types-by-introspection "Pango")
~mdw / clg / commitdiff